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A   FORTRAN    ROUTINE    REORGANIZER 

by 

Marvin  S.  Seppanen  ^ 


ABSTRACT 

Computer  programers  are  often  required  to  make  modifications  to  unfamil- 
iar Fortran  routines.   This  Bureau  of  Mines  report  describes  a  computer  pro- 
gram designed  to  aid  the  programer  in  such  a  situation  by  reorganizing  Fortran 
routines.   This  reorganization  includes  a  sequential  renumbering  of  the  rou- 
tine's statement  numbers,  a  sequential  renumbering  and  relocation  of  format 
statements,  an  alphanumeric  reordering  of  dimensioned  and  typed  variables,  a 
uniform  pattern  of  text  spacing,  and  a  sequential  numbering  of  the  records  in 
the  final  Fortran  routine. 

The  computer  program  has  been  extensively  tested  by  the  author  and  has 
proved  to  be  a  valuable  tool  for  reorganizing  Fortran  routines  developed  under 
contract  and  later  utilized  by  the  Bureau,  and  for  preparing  routines  for 
publication. 

INTRODUCTION 

Most  computer  programs  are  never  finished  to  the  programer 's  satisfaction 
because  deadlines  force  the  programer  to  leave  the  program  at  an  intermediate 
working  point  short  of  the  capabilities  and  options  desired  for  the  program. 
The  program  responsibility  is  often  consigned  to  an  operating  agency,  or  the 
program  is  distributed  to  outside  users,  by  the  original  programer.   Even  when 
the  original  programer  remains  in  contact  with  his  work,  months  can  elapse 
before  further  work  can  be  done  to  improve  the  logic.   This  transfer  or  delay 
means  that  most  additional  programing  is  done  by  programers  unfamiliar,  or  out 
of  date,  with  the  coding.   Working  with  an  unfamiliar  program  is  difficult 
because  the  logic  is  often  scattered  and  the  statement  numbers  are  seldom  in 
either  a  logical  or  numerical  sequence.   Also,  during  execution  a  program  will, 
on  occasion,  terminate  in  an  error  condition,  necessitating  an  error  trace- 
back  through  the  source  program.   This  normally  requires  a  study  of  the  pro- 
gram's FORMAT  statements  and  the  associated  output  statements  to  determine 
where  the  error  occurred  in  the  logic.   Finding  a  particular  FORMAT  statement 
in  an  unfamiliar  program  can  be  a  difficult  task. 

^Operations  research  analyst  (now  with  the  University  of  Alabama,  University, 
Ala.). 


To  aid  the  programer  in  these  situations,  a  reorganization  program  (REOR) 
was  developed  by  the  Bureau  of  Mines  to  reorganize  Fortran  routines  into  a 
standard  form.   This  reorganization  includes  a  sequential  renumbering  of  the 
routine's  statement  numbers,  a  sequential  renumbering  and  relocation  of  format 
statements,  and  alphanumeric  reordering  of  dimensioned  and  typed  variables,  a 
uniform  pattern  of  text  spacing,  and  a  sequential  numbering  of  the  records  in 
the  final  Fortran  routine. 

The  reorganized  Fortran  routine  follows  the  general  conventions  of  pro- 
graming style  indicated  by  Kernighan  and  Plauger  (3).^      The  resequencing  of 
statement  numbers  is  a  major  aid  in  avoiding  unnecessary  branches  and  in 
assuring  that  the  routine's  statement  order  follows  the  processing  order.   The 
uniform  text  spacing  is  beneficial  when  searching  for  potential  error  condi- 
tions.  The  indented  DO  loops  provide  a  visual  reminder  to  the  programer  to 
observe  its  limits. 

Other  programs  such  as  TIDY  are  available  that  perform  a  function  similar 
to  REOR.   REOR  requires  less  computer  memory  than  the  University  of  Minnesota 
version  of  TIDY.   That  version  of  TIDY  offers  the  user  a  large  set  of  options 
not  available  to  the  REOR  user.   The  REOR  user  is  not  required  to  individually 
specify  those  desirable  options.   REOR  also  does  a  more  comprehensive  reorgani- 
zation of  Hollerith  fields  in  both  FORMAT  and  DATA  statements. 

Being  single  purpose  and  written  in  a  modular  form,  REOR  can  be  easily 
modified  for  special  Fortran  conversion  operations.   For  example,  with  a  minor 
programing  change  REOR  was  used  to  identify  special  nonstandard  mass  storage 
input-output  statements  in  one  large  set  of  programs  being  converted  from  one 
computer  hardware  to  another.   While  not  included  in  that  case,  REOR  could  be 
programed  to  automatically  make  such  conversions. 

THE  PROGRAM  (REOR) 

The  program  (REOR)  was  written  in  the  Fortran  IV  extended  language  for 
the  Control  Data  Corp.  (CDC)  6000  series  computer^  in  the  batch  mode  of  opera- 
tion.  REOR  reorganizes  routines  written  in  a  code  compatible  with  that  com- 
puting system  and  other  American  National  Standards  Institute  (ANSI)  standard 
Fortran  compilers.   The  reorganized  routine  code  is  general  enough  to  allow 
its  use  with  any  ANSI  standard  Fortran  compiler. 

REOR  uses  one  input  file  containing  the  original  Fortran  routines.   It 
assumes  that  these  routines  are  of  a  quality  suitable  for  error-free  compila- 
tion.  The  primary  output  is  the  file  of  reorganized  Fortran  routine  statement. 
This  file  is  in  a  form  suitable  for  compilation,  listing,  or  punching.   REOR 
also  prints  information  about  its  execution.   A  summary  table  is  printed  after 
each  routine  has  been  processed.   REOR  compensates  for  most  errors  in  the  rou- 
tine being  organized.   When  faced  with  an  error  condition,  REOR  makes  the 

^Underlined  numbers  in  parentheses  refer  to  items  in  the  bibliography  preced- 
ing the  appendixes. 
Reference  to  specific  equipment  does  not  imply  endorsement  by  the  Bureau  of 
Mines . 


necessary  assumptions  to  continue  processing  and  prints  messages  to  indicate 
the  error  condition  and  the  actions  taken.   REOR  checks  each  of  its  internal 
storage  arrays  to  assure  that  they  remain  within  bounds.   Error  messages  indi- 
cate overflow  conditions. 


An  effort  has  been  made  to  make  REOR's  execution  as  efficient  as  possible; 
however,  its  execution  does  require  a  substantial  amount  of  both  central  and 
peripheral  processor  time.   Execution  time  is  a  function  of  the  original  rou- 
tine's length  and  the  individual  statement's  type,  complexity,  and  length. 
Experience  with  the  CDC  6600  has  indicated  that  reorganizing  a  100-record  rou- 
tine requires  about  3.3  seconds  of  central  processor  time,  and  about  17  sec- 
onds of  peripheral  processor  time.   The  CDC  6600  execution  core  requirement 
under  the  SCOPE  operating  system  is  43,200  octal  words. 
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FIGURE  1.  -  REOR  program  macrologic. 


REOR's  output  form  is 
illustrated  by  its  own  list 
in  appendix  A.   That  list 
demonstrates  most  of  REOR's 
capabilities.   The  individ- 
ual REOR  routines  are  docu- 
mented with  comment  state- 
ments ,  and  appendix  B 
contains  a  functional 
description  for  each  of  the 
27  separate  routines. 
Appendix  C  is  a  list  of 
definitions  for  the  vari- 
ables used  by  REOR.   Appen- 
dix D  illustrates  the  normal 
set  of  SCOPE  control  cards 
required  to  execute  the  pro- 
gram from  an  object  code 
file  REOR  resident  on  disk. 

REOR  Logic 

Program  REOR  operates 
through  three  basic  process- 
ing cycles--read ,  write,  and 
reset.   Figure  1  illustrates 
the  macro  flow  chart  for  the 
REOR  program.   The  read 
cycle  uses  subroutine  READS 
to  read  the  original  Fortran 
routine  from  logical  unit 
TAPE  2,  and  to  interpret 
each  statement.   The  state- 
ments are  either  stored 
internally  or  written  on  a 
working  file,  TAPE  3.   Fig- 
ure 2  is  a  flow  chart  of  the 
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FIGURE  2,  •  READS  subroutine  logic. 


READS  subroutine  logic.   The  write  cycle  uses  subroutine  WRITES  to  reconstruct 
and  to  write  the  reorganized  Fortran  routine  on  logical  unit  TAPE  4.   Figure  3 
is  a  flow  chart  of  the  WRITES  subroutine  logic.   At  the  close  of  the  write 
cycle  REOR  prints  a  summary  of  the  processing  for  current  routine.   If  the 
last  reading  operation  from  TAPE  2  encountered  an  End-of-File  (EOF)  m.ark,  EXIT 
is  called  and  the  execution  of  REOR  is  terminated.   If  more  routines  are  pres- 
ent on  TAPE  2,  subroutine  RESETS  is  called  to  reset  the  counters  and  pointers. 
The  read  cycle  is  then  repeated  for  the  next  routine.   Each  routine  is  pro- 
cessed independently. 

Read  Cycle 

The  read  cycle  individually  processes  each  Fortran  statement.   These 
statements  may  occur  on  a  single  80-column  input  record,  or  may  be  continued 
on  one  or  more  continuation  records  following  the  standard  Fortran  record 
layout  convent ion --columns  1-5,  statement  number;  column  6,  continuation  mark; 
columns  7-72;  executable  statements;  and  columns  73-80,  comments.   More  than 
one  executable  statement  may  be  contained  in  a  single  record  if  properly  delin- 
eated with  a  dollar  ($)  sign.   This  feature  agrees  with  CDC  Fortran  convention. 
To  make  the  reorganized  routine  coding  more  widely  compatible,  all  multiple 
statements  are  separated  and  processed  individually. 

When  the  read  cycle  is  initiated,  REOR  first  seeks  to  find  the  routine 
identification  statement.   This  identification  may  be  of  one  of  the  following 
types:   PROGRAM,  SUBROUTINE,  FUNCTION,  BLOCK  DATA,  or  typed  function.   Failure 
to  find  such  a  statement  results  in  an  error  condition.   This  condition  is 
nonfatal,  but  does  cause  a  message  to  be  printed.   The  first  four  alphanumeric 
characters  of  the  routine's  name  are  retained  for  output  labeling.   If  no 
valid  identification  statement  is  found,  the  label  NAME  is  assumed.   If  the 
routine  is  of  the  BLOCK  DATA  type,  it  may  not  have  a  name,  in  which  case  the 
label  DATA  is  assumed. 

Each  subsequent  statement  is  identified  and  processed  according  to  its 
characteristics.   Variables  defined  by  type  of  DIMENSION  statements  are  col- 
lected, sorted  in  alphanumeric  order,  and  stored  internally  for  final  process- 
ing.  FORMAT  statments  are  cataloged,  condensed,  and  stored  internally  for 
final  processing.   Hollerith  fields  in  the  original  routine  can  be  of  the  fol- 
lowing types:   4HTEXT,  *texT*,  or  'TEXT'.   None  of  their  internal  spacing  is 
altered.   Consecutive  "TEXT*  or  'TEXT'  type  Hollerith  fields  separated  by  only 
spaces  and/or  a  comma  are  combined  into  a  single  field  by  deleting  the  sepa- 
rating character  and  spaces. 

With  the  exception  of  the  END  statement,  the  remaining  statements  are 
adjusted  to  obtain  consistent  internal  spacing  and  written  on  the  working  file. 
The  rules  for  internal  spacing,  except  for  Hollerith  fields,  follow: 

1.  Commas  are  always  followed  by  a  space. 

2.  Closed  parentheses  are  preceded  by  a  space. 

3.  Equal  signs  are  preceded  and  followed  by  two  spaces. 
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FIGURE  3.  -  WRITES  subroutine  logic. 


4.  Arithmetic  symbols  (+ ,  *,  -,  or  /)  are  preceded  and  followed  by  a 
space. 

5.  Logical  operations  within  IF  statements  are  preceded  and  followed  by 
a  space. 

6.  Special  Fortran  words  (IF,  DO,  GO,...)  are  separated  from  other  text 
by  spaces. 

Comment  statement  spacing  is  not  altered.   The  letter  C  is  inserted  in  col- 
umn 1  of  blank  comment  records  or  where  the  comment  statement  began  with  an 
asterisk.   When  more  than  one  consecutive  blank  comment  statement  is  found, 
all  but  the  first  are  omitted.   All  Hollerith  fields  in  DATA  statements  are 
converted  to  the  4HTEXT  type.   Statement  types  that  internally  contain  state- 
ment numbers  (GO  TO  99,  DO  99...,  etc.)  are  scanned  to  locate  those  references. 
Statements  whose  type  cannot  be  identified  are  assumed  to  be  replacement 
expressions.   These  are  scanned  to  assure  that  they  contain  an  equal  sign. 
Failure  to  find  an  equal  sign  is  noted  by  an  error  message.   Originally  num- 
bered executable  statements  are  renumbered  sequentially  beginning  with  1,000 
in  increments  of  10.   RETURN  statements  contained  within  a  FUNCTION  or 
SUBROUTINE  are  converted  to  GO  TO  9999  statements.   The  last  statement  of  the 
routine  is  of  the  RETURN  type  and,  if  necessary,  is  numbered  9999. 

The  read  cycle  is  terminated  when  an  END  statement  or  an  EOF  is  read. 
The  working  file  is  rewound,  and  the  write  cycle  is  started. 

Write  Cycle 

The  write  cycle  individually  processes  each  routine  statement  on  the 
working  file.   Each  statement  is  composed  into  standard  80-column  Fortran 
records.   The  text  of  each  noncomment  statement  begins  in  column  8  of  the  out- 
put record.   Statements  extending  beyond  column  72  are  continued  on  subsequent 
records.   Whenever  possible  the  text  division  for  the  continuation  record  is 
made  at  a  space  in  the  text.   These  continuation  statements  are  numbered  1, 
2,  ...,  8,  9,  ...,  in  column  6.   Generally,  the  continuation  record  text  is 
indented  two  spaces  to  the  right  from  the  first  record.   The  exception  to  this 
rule  occurs  in  FORMAT  or  DATA  where  4HTEXT-type  Hollerith  fields  continue  from 
column  72  of  one  record  onto  column  7  of  the  next.   To  provide  the  indented 
form,  *TEXT*  and  'TEXT'  fields  in  FORMAT  statements  are  terminated  in  col- 
umn 71  and  resume  in  column  11  of  the  continuation  record.   The  proper  punctu- 
ation is  inserted  to  retain  the  meaning  of  the  text.   DO  loops  are  indented  by 
an  additional  two  columns  to  provide  a  readily  noticed  appearance.   Concurrent 
DO  loops  are  cumulatively  indented  two  columns  each.   Each  output  record  is 
labeled  in  columns  73-76  with  the  routine  name  or  substitute  generated  in  the 
read  cycle.   A  sequence  number  beginning  with  and  incremented  by  10  is  written 
in  columns  77-80.   Sequence  numbers  in  excess  of  9990  are  prevented  by  shift- 
ing an  asterisk  to  column  76  and  restarting  the  sequence  numbering  with  10. 

Prior  to  writing  the  first  EQUIVALENCE,  DATA,  or  executable  statement, 
the  dimensioned  and  typed  variables  are  reconstructed  from  internal  storage 
and  written.   All  variables  of  a  single  type  are  placed  in  a  single  statement. 


The  order  of  the  types  used  is  DIMENSION,  EXTERNAL,  COMPLEX,  DOUBLE,  INTEGER, 
LOGICAL,  and  REAL.   The  redundant  words  PRECISION  and  TYPE  are  deleted  from 
the  output  statements. 

The  executable  statements  are  transferred  from  the  working  file  to  the 
output  file.   The  new  statement  numbers  assigned  in  the  read  cycle  are  used. 
Internal  statement  number  references  are  changed  to  be  consistent  with  the  new 
numberings . 

Prior  to  writing  the  END  statement,  any  FORMAT  statements  are  recon- 
structed from  internal  storage  and  written.   The  FORMAT  statements  are  ordered 
according  to  their  first  use  in  the  routine  and  are  numbered  sequentially  10, 
20,  30,  ...,  990.   A  referenced  FORMAT  statement  that  is  not  found  in  the 
original  routine  is  noted  with  an  error  message  and  written  as  a  default  (Al) 
FORMAT  statement  in  the  reorganized  routine.   An  unreferenced  FORMAT  statement 
is  deleted. 

Limitations 

REOR  is  limited  by  the  type  of  the  Fortran  code  which  can  be  used  in  the 
original  routine,  and  by  the  size  of  the  internal  storage  allocated  for  cer- 
tain types  of  information.   The  language  characteristics  of  several  special 
CDC  compilers  have  been  incorporated  into  REOR.   These  include  the  special  CDC 
input -output  procedures  BUFFERIN,  BUFFEROUT,  DECODE,  and  ENCODE.   Other 
equipment -dependent  functions  have  not  been  incorporated.   REOR's  internal 
information  storage  method  places  several  limitations  on  the  size  of  routines 
and  statements  it  can  process.   These  error  conditions  and  recovery  procedures 
are  presented  in  table  1. 

One  Fortran  condition  is  known  to  create  an  error  situation.   Because  of 
its  complex  nature  and  infrequent  use,  it  has  not  been  handled  by  REOR.   This 
condition  arises  from  the  CDC  Fortran  IV  extended  compiler  capability  to  use 
Hollerith  fields  as  arguments  in  routine  calling  statements,  as  logical  oper- 
ators, or  as  the  right  member  of  replacement  expressions.   Such  usage  will 
cause  a  potential  problem  when  the  Hollerith  field  contains  an  unequal  number 
of  left  and  right  parentheses  or  blanks.   This  is  a  problem  when  the  Hollerith 
field  is  part  of  the  logical  or  arithmetic  expression  of  an  IF  statement. 
Such  a  statement  may  not  be  properly  handled,  and  an  error  message  will  note 
the  condition. 

REOR  was  coded  for  the  CDC  Fortran  extended  compiler.   As  such,  it  uses 
several  CDC  features  that  may  not  be  available  on  all  compilers.   These 
include  the  EOF  check  function,  the  10 -character  word  length,  and  the  DECODE 
and  ENCODE  statments.   Use  of  these  statements  and  function  should  be  verified 
before  attempting  to  compile  REOR  with  other  than  the  CDC  Fortran  extended 
compiler. 


TABLE  1.  -  Error  conditions  and  recovery  procedures 


Error  message 

Constraint 

Recovery  procedure 

Detection 

variable 

location 

Array  STRING  filled  with 

NMAX 

This  and  all  following  typed 

STORE  440 

more  than  100  dimensioned 

or  dimensioned  variables 

or  tjrped  variables. 

deleted,  processing 
continues . 

Array  LSTATE  filled  with 

MLCHARS 

Remainder  of  statement 

TRANSF 

more  than  2,000  statement 

deleted,  processing 

150 

characters. 

continues. 

Array  INNUM  filled  with 

NUMMAX 

Remaining  internal  state- 

KLIST 150 

more  than  50  internal 

ment  numbers  not  altered, 

statement  numbers. 

processing  continues. 

Array  KFORM  filled  with 

MNFORM 

Remaining  original  FORMAT 

KF  220 

more  than  99  original 

statement  number  calls  are 

FORMAT  statement  number 

not  recorded,  processing 

calls. 

continues. 

Array  KFOUT  filled  with 

NFORM 

Remaining  FORMAT  statements 

KO  220 

more  than  100  original 

and  numbers  are  not 

FORMAT  statement  numbers 

recorded,  processing 
continues. 

Array  LFOUT  filled  with 

MFORM 

Current  FORMAT  statement  is 

KO  270 

more  than  1,000  FORMAT 

not  recorded,  processing 

statement  words. 

continues. 

Array  KSNUM  filled  with 
more  than  400  executable 

MNSTATE 

Routine  deleted 

READS 

3380 

statements  numbers. 
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APPENDIX  A. --PROGRAM  LIST  (REOR) 


PROGRAM      KEOH  CDC  6600  FTn  V3.0-P355  0PT=1   06/2S/75   12.55.39. 

PROGRAM   REOR  (TAPE2.  TAPE3.  TAPE4*   OUTPUT)  REOR  10 

C     THIS  PROGRAM  READS  A  STANDARD  FORTRAN  ROUTINE  FILE  AND  REORGANIZES  REOR  20 

C       THE  ROUTINE  Br  ORDERING  THE  STATEMENT  NUMBERS  AND  ADJUSTING  THE  REOR  30 

C       STATEMENT  SPACING  AND  ORDER.  REOR  40 

5                  COMMON   /ALL/   ICHARS,  IDOLLAR»  lERROR,  INNUM  (2,  50).  IPOINT,  REOR  50 

1  IPROG.  ISNUM,  ITYPt.  19999.  KFORM  (100).  KFOUT  (3.  100).  KSNUM  REOR  60 

2  (2.  '♦OO).  LCARD  (80).  LCHARS.  LFOUT  (1000).  LSTATE  (2000).  REOR  70 

3  LWOROS,  NAME  (A).  NCARDS.  NEAT.  NFORMN.  NFOUT.  NKFORM.  NOUTS.  REOR  80 
i*         NPUSH.  NSNUMC.  NSTATN.  NUMBER  (7).  NUMIN.  NUMK.  NVALUE.  STRING  REOR  90 

10               5    (2.  100)  REOR  100 

COMMON   /DATA/   C.  END.  H.  IBLANK.  lEOF.  INTEGER  (10).  IPUNCT  REOR  110 

1  (II).  ICOUNT  (2.  A).  LUIN.  LUOUT.  LUSTATE.  MFOUT .  MLChARS.  REOR  120 

2  MNFORM.  MNSTATE.  NCAHC.  NMAX.  NUMMAX.  PROGRAM  (7).  RETURN.  REOR  130 

3  STAR.  X  REOR  UO 
15                 INTEGER      C.  END.  H.  lOATA  (4613).  PROGRAM.  RETURN.  STAR.  REOR  150 

1    STRING.  X  REOR  160 

EQUIVALENCE   (ICHARS.  ICATA(l))  REOR  170 

DATA     ICOUNT.  IDATA  /  8  *>  0.  4613  »  0  /  REOR  180 

DATA     C.  END.  H.  IBLANK.  lEOF  /  IhC.  JhEND.  IHH.  IH  .  0  /  REOR  190 

20                 DATA     INTEGER  /  IHO.  Ihl.  1H2.  1H3.  1H4.  1H5.  1H6.  1H7.  1H8.  REOR  200 

1    1H9   /  REOR  210 

DATA     IPUNCT  /  IH/.  II-..  1H(.  IH).  1H«.  IHi.  IH..  1H=.  1H-.  REOR  220 

1  IH*  .  IH*   /  REOR  230 
DATA     LUIN.  LUOUT.  LUSTATE.  MFOUT.  MLCHARS.  MNFORM.  MNSTATE.  REOR  240 

25                1    NCARD.  NMAX.  NUMMAX.  RETURN.  STAR.  X  /  2.  4,   3.  1000.  2000.  REOR  250 

2  99.  400.  0.  100.  50.  6HRETURN.  1H*».  IHX   /  REOR  260 
DATA     PROGRAM  /  IHP.  IHR.  IHO.  IHG.  IHR,  IHA.  IHM   /  REOK  270 

C     DO  THE  HOUSEKEEPING  OPERATIONS.  REOR  280 

1000   CALL  RESETS  REOR  290 

30           C     DO  THE  READ  CYCLE.   READ  THE  STATEMENTS  FOR  A  ROUTINE  FROM  THE  REOR  300 

C       INPUT  FILE  TAPE2.  PROCESS,  AND  STORE  ON  THE  WORKING  FILE  TAPEIO.  REOR  310 

CALL  READS  REOR  320 

C     DO  THE  WRITE  CYCLE.   READ  THE  STATEMENTS  FROM  THE  WORKING  FILE.  REOR  330 

C       COMPLETE  THE  PROCESSING.  AND  WRITE  ON  THE  OUTPUT  FILE  TAPE4.  REOR  340 

35                  CALL  WRITES  REOR  350 

C     REPEAT  IF  NO  EOF  ENCOUNTERED.  REOR  360 

IF  (lEOF  .EU.  0)   GO  TO  1000  REOK  370 

CALL  EXIT  REOR  380 

END  REOR  390 
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SUBf^OUTINE   BLANKS  CDC  6600  FTN  V3.0-P355  0PT=1  06/2b/75   12.55.39. 

SUBROUTINE   BLANKS  BLAN   10 

c    This  routine  surpresses  all  blanks  in  the  array  list  except  for  blan  20 

C       those  in  HOLLERITH  TYPE  STATEMENTS.  8LAN   30 

common   /all/   ICHARS,  IOOLLAR,  IERROR.  INNUM  (2.  50).  IPOINT,  BLAN   <tO 

5  1    IPROG.  ISNUM,  ITYPE.  19999.  KFORM  (100).  KFOUT  (3.  100).  KSNUM  BLAN   50 

2  (2.  '♦00)»  LCARD  (80).  LCHARS.  LFOUT  (1000)»  LSTATE  (2000).  BLAN   60 

3  LWORDS.  NAME  (4).  NCARDS.  NEXT.  NFORMN.  NFOuT.  NKFORM.  NOUTS,   BLAN   70 

4  NPUSH.  NSNUMC.  NSTATN.  NUMBER  (7).  NUMIN,  NuMK.  NVALUE.  STRING  BLAN   80 

5  (2.  100)  BLAN   90 
10                  COMMON   /DATA/   C.  END.  H.  IBLANK.  lEOF.  INTEGER  (10).  IPUNCT  BLAN  100 

1  (11).  ICOUNT  (2.  4).  LUIN.  LUOUT.  LUSTATE.  MFOUT.  MLChARS.  BLAN  HO 

2  MNFORM,  MNSTATE.  NCARC.  NMAX.  NUMMAX.  PROGkaM  (7).  RETURN.  BLAN  120 

3  STAR.  X  BLAN  130 
DIMENSION    LIST  (1)  BLAN  1^0 

15  INTEGER      C.  H.  STAR.  X  BLAN  150 

EQUIVALENCE   (LIST(l).  LSTATE(1))»  (ISTOP.  LCHARS)  BLAN  160 

I   =   1  BLAN  170 

IDOLLAR   =   0  BLAN  180 

ISTOP   =   NONR  (IBLANK.  1.  ISTOP.  LIST(l))  BLAN  190 

20  1000   IF  (SPRESSd. ISTOP. LIST(l)  )  .NE.  0.0)   GO  TO  1190  BLAN  200 

C     CHECK  FOR  A  LEADING  PUNCTUATION  MARK.  BLAN  210 

1010     DO  1020   J   =   1.  6  BLAN  220 

IF  (LIST(I)  .EQ.  IPUNCT(J))   GO  TO  1030  BLAN  230 

1020     CONTINUE  BLAN  2^*0 

25  J   =   11  BLAN  250 

IF  (LIST(I)  .EQ.  IPUNCT(J))   GO  TO  1040  BLAN  260 

1=1*1  BLAN  270 

GO  TO  1000  BLAN  280 

C     CHECK  FOR  A  DOLLAR  SIGN.  J.  INDICATING  A  MULTIPLE  STATEMENT  RECORD. BLAN  290 

30  1030   IF  (J  .EQ.  6)   GO  TO  1180  BLAN  300 

C     CHECK  FOR  A  «  TO  BEGIN  A  HOLLERITH  FIELD.  BLAN  310 

IF  (J  .NE.  5)   GO  TO  1050  BLAN  320 

(ITYPE  .EQ.  17)   GO  TO  1130  BLAN  330 

(ITYPE  .EG.  16)   GO  TO  1150  BLAN  340 

35  C  BLAN  350 

=   1*1  BLAN  360 

(SPRESSd. ISTOP. LIST(l)  )  .NE.  0.0)   GO  TO  1190  BLAN  370 

DO  1070   J   =   1.  10  BLAN  380 

IF  (LIST(I)  .EQ.  INTEGER(J))   60  TO  1080  BLAN  390 

40  1070     CONTINUE  BLAN  400 

GO  TO  1010  BLAN  410 

1080   N   =   J  -  1  BLAN  420 

1090   1=1*1  BLAN  430 

IF  (SPRESSd. ISTOP.LIST(l)  )  .NE.  0.0)   GO  TO  1190  BLAN  440 

45  C     CHECK  FOR  AN  H.   INDICATES  A  HOLLERITH  FIELD.  BLAN  450 

IF  (LIST(I)  .EQ.  H)   60  TO  1120  BLAN  460 

C     CHECK  FOR  AN  <».   INDICATES  A  MUTIPLE  DATA  ASSIGNMENT.  BLAN  470 

IF  (LIST(I)  .EQ.  STAR)   GO  TO  1050  BLAN  480 

C     CHECK  FOR  MORE  NUMBERS.  BLAN  490 

50  DO  1100   J   =   1.  10  BLAN  500 

IF  (LISTd)  .EQ.  INTEGER(J))   GO  TO  1110  BLAN  510 

1100     CONTINUE  BLAN  520 

GO  TO  1010  BLAN  530 

1110   N   =   N»10*J-1  BLAN  540 

55  60  TO  1090  BLAN  550 


1040 

IF 

IF 

c 

1050 

I 

1060 

IF 
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SUBROUTINE   BLANKS  COC  6600  FTN  V3.0-P355  0PT=1   06/2b/75   12.55.39. 

C     SKIP  THE  ENTIRE  H  FIELD  OF  LENGTH  N.  BLAN  560 

1120   I   =   I  ♦  1  ♦  N  BLAN  570 

GO  TO  1010  BLAN  580 

C    hErtE  FOR  J  =  17.  FORMAT  STATEMENTS.  BLAN  590 

60           C     SKIP  THE  CHARACTERS  BETWEEN  THE  «  OR  *  SIGNS.  BLAN  600 

C    DELETE  ANY  TRAILING   COMMA.  BLAN  610 

1130   I   =   ISCANL  (IPUNCKJ).  I  ♦  1.  ISTOP»  LIST(l))  ♦  1  BLAN  620 

IF  (SPRESSd.ISTOPtLISTd))  .NE.  0.0)   GO  TO  1190  BLAN  630 

IF  (LIST(I)  .NE.  IPUNCT(2))   GO  TO  11^0  BLAN  6^*0 

65                   CALL  SHIFTL  (IBLANK.  I»  ISTOP.  LIST(l))  BLAN  650 

IF  (SPRESSd.ISTOP.LIST  (1)  )  .NE.  0.0)   GO  TO  1190  BLAN  660 

C    COMBINE  CONSECUTIVE  SIMILIAR  «  OR  i«  FIELDS.  BLAN  670 

U'^O   IF  (LIST(I)  .NE.  IPUNCT(J))   GO  TO  1010  BLAN  680 

CALL  SHIFTL  (IBLANK,  I,  I3T0P.  LIST(l))  BLAN  690 

70                  1=1-1  BLAN  700 

CALL  SHIFTL  (IBLANK.  I.  ISTOP.  LIST(l))  BLAN  710 

IF  (I  .GT.  ISTOP)   GO  TO  1190  BLAN  720 

GO  TO  1130  BLAN  730 

C    HERE  FOR  J  =  16.  DATA    STATEMENTS.  BLAN  740 

75           C     CONVERT  A  »XXX«  OR  ^XAX*  TO  A  3HXXX  (CDC)  BLAN  750 

1150   LIST  (I)   =   H  BLAN  760 

II   =   1*2  BLAN  770 

N   =   1  BLAN  780 

1160   IF  (II  .GT.  ISTOP)   GO  TO  1190  BLAN  790 

80                  IF  (LIST(II)  .EQ.  IPUNCT(J))   GO  TO  1170  BLAN  800 

II   =   11*1  BLAN  810 

N   =   N  ♦  1  BLAN  820 

GO  TO  1160  BLAN  830 

1170   CALL  SHIFTL  (IBLANK,  II»  ISTOP,  LIST(l))  BLAN  840 

85                   CALL  INSERTN  (N.  I,  ISTOP,  LIST(l))  BLAN  850 

60  TO  1060  BLAN  860 

C  BLAN  870 

1180   IDOLLAR   =   I  BLAN  880 

ICHARS   =   IDOLLAR  -  1  BLAN  890 

90                  GO  TO  9999  BLAN  900 

1190   ICHARS   =   LCHARS  BLAN  910 

9999   RETURN  BLAN  920 

END  BLAN  930 
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FUNCTION 


CHECK 


CDC  6600  FTN  V3.0-P355  0PT=1   06/25/75   12.55.39, 


10 


15 


20 


1000 


1010 
1020 


LOGICALFUNCTION   CHECK  (L00K4,  NN. 
THIS  FUNCION  SCANS  A  DATA  LIST  FOR  A 
DIMENSION    LIST  (1),  LOCKUP  (10) 
DECODE  (10.    10.  LOOK^)   LOOKUP 
J   =   ISTAKT  -  1 

DO  1020   I   =   1.  NN 

J   =   J  ♦  1 

IF  (J  .GT.  ISTOP)   GO  TO  1030 

IF  (LIST(J)  .NE.  IBLANK)   GO  TO  1010 

CALL  SHIFTL  (IBLANK,  j.  ISTOP.  LIST(l)) 

GO  TO  1000 

IF  (LOOKUP(I)  .NE.  LIST(J))   GO  TO  1030 

CONTINUE 
CHECK   =   .TRUE. 
IPOINT   =   J  ♦  1 
GO  TO  9S99 


ISTART,  ISTOP.  LIST. 
SPECIFIC  DATA  STRING 


1030 


9999 


CHECK 

IPOINT 

RETURN 


.FALSE. 
ISTART 


10   FORMAT   (  lOOAl  ) 


END 


IPOINT)   OPEC 

10 

(L00K4).  CHEC 

20 

CHEC 

30 

CHEC 

40 

CHEC 

SO 

CHEC 

60 

CHEC 

70 

CHEC 

80 

CHEC 

90 

CHEC 

100 

CHEC 

110 

CHEC 

120 

CHEC 

130 

CHEC 

140 

OHEC 

150 

CHEC 

160 

CHEC 

170 

CHEC 

180 

CHEC 

190 

CHEC 

200 

CHEC 

210 

CHEC 

220 

CHEC 

230 

IS 


SUBROUTINE   FIXOATA  COC  6600  FTN  V3.0-P355  OPT:il   06/25/75   12.55.39. 

SUBROUTINE   FIXOATA  FIXO   10 

C     THIS  ROUTINE  ASSURE  THAT  ThE  HOLLERITH  FIELDS  IN  DATA  STATEMENTS  FIXO   20 

C       ARE  PROPERLY  HANDLED.  FIXO   30 

COMMON  /ALL/  1CHARS»  lOOLLAR,  lERRORt  INNUM  (2»  50).  IPOINT*  FIXO  ^0 
5                 1    IPROG.  ISNUM.  ITYPE,  I99S9f  KFORM  <100).  KFOUT  (3»  100).  KSNUM  FIXD   50 

2  (2.  ^.00).  LCARD  (80).  LCHARS.  LFOUT  (1000).  LSTATE  (2000).  FIXD   60 

3  LWOROS.  NAME  C).  NCAROS.  NEXT.  NFORMN.  NFOUT.  NKFORM.  NOUTS.  FIXD  70 
U  NPUSH.  NSNUMC.  NSTATN.  number  (7).  NUMIN.  NUMK.  NVALUE.  string  FIXD  80 
5    (2.  100)  FIXD   90 

10  COMMON   /DATA/   C.  END.  H.  IBLANK.  lEOF.  INTEGER  (10).  IPUNCT  FIXD  100 

1  (11).  ICOUNT  (2.  4).  LUIN.  LUOUT.  LUSTATE.  MFOUT .  MLCHARS.  FIXD  110 

2  MNFORM,  MNSTATE.  NCARC.  NMAX.  NUMMAX.  PROGRAM  (7).  RETURN.  FIXD  120 
J    STAR.  X  FIXD  130 

C     SCAN  FOR  The  THE  H  WHICH  HAY  BE  THE  START  OF  A  HOLLERITH  FIELD  FIXD  140 

15  INTEGER      H  FIXO  150 

II   =   10  FIXD  160 

1000   IH   =   ISCANL  (H.  II.  LCHARS.  LSTATE(l))  FIXD  170 

IF  (IH  .GE.  LCHARS)   GO  TO  9999  FIXD  180 

IS   =   IH  -  1  FIXD  190 

20  C     DETERMINE  IF  THE  H  IS  PRECEEDEO  BY  AN  INTEGER.  FIXD  200 

IF  (LSTATE(IS)  .EU.  IBLANK)   GO  TO  1080  FIxD  210 

DO  1010   I   =   1.  10  FIXD  220 

IF  (LSTATE(IS)  .EQ.  INTEGER(I))   GO  TO  1020  FIXO  230 

1010     CONTINUE  FIXD  2^.0 

25  GO  TO  1080  FIXD  250 

1020   N   =   I  -  1  FIXO  260 

IS   =   IS  -  1  FIXD  270 

IF  (LSTATE(IS)  .E(J.  IBLANK)   GO  TO  1070  FIXD  280 

DO  1030   I   =   1.  10  FIXD  290 

30  IF  (LSTATEdS)  .EQ.  INTEGER(I))   GO  TO  1040  FIXD  300 

1030     CONTINUE  FIXO  310 

GO  TO  1080  FIXD  320 

1040   N   =   N  ♦  10  »  (I  -  1)  FIXD  330 

IS   =   IS  -  1  FIXD  340 

35  IF  (LSTATEdS)  .EQ.  IBLANK)   GO  TO  1070  FIXD  350 

DO  1050   I   =   1.  10  FIXD  360 

IF  (LSTATEdS)  .EQ.  INTEGER(I))   GO  TO  1060  FIXD  370 

1050     CONTINUE  FIXD  380 

GO  TO  1080  FIXD  390 

40  1060   N   =   N  ♦  100  »  (I  -  1)  FIXD  400 

IS   =   IS  -  1  FIXD  410 

IF  (LSTATEdS)  .NE.  IBLANK)   GO  TO  1080  FIXD  420 

C     DETERMINE  IF  THE  INTEGER  IS  PRECEEDED  BY  A  /.  COMMA.  OR  ».  FIXD  430 

1070   IS   =   IS  -  1  FIXO  440 

45  IF  (LSTATEdS)  .EQ.  IPUNCT(l))   GO  TO  1090  FIXD  450 

IF  (LSTATEdS)  .EQ.  IPbNCT(2))   GO  TO  1090  FIXD  460 

IF  (LSTATEdS)  .EQ.  IPUNCT(5))   GO  TO  1090  FIXD  470 

1080   II   =   IH  ♦  2  FIXD  480 

GO  TO  1000  FIXD  490 

50  1090   IS   =   IH  ♦  N  FIXD  500 

IH   =   IH  ♦  1  FIXD  510 

DO  1100   I   =   IH.  IS  FIXO  520 

1100     LSTATE  (I)   =   LSTATE  (I)  ♦  1  FIXD  530 

n   =   IS  ♦  3  FIXD  540 

55  GO  TO  1000  FIXD  550 

9999   RETURN  FIXO  560 

END  FIXD  570 


16 


FUNCTION 


lOENT 


CDC  6600  FTn  V3.0-P355  0PT=1   06/25/75   12.55.39. 


10 


15 


20 


25 


30 


35 


40 


45 


50 


55 


FUNCTION   IDENT  (N)  IDEN 

THIS  ROUTINE  MATCHES  CHARACTER  STRINGS  IN  THE  LIST  ISTATE  TO  A       lOEN 

MASTER  LIST.  lA.  WHERE.  lOEN 

lA  (1»X)   IF  THE  CHARACTER  IN  THE  LIST  LSTATE  EXCEEDS  THE  MATCHIDEN 

CHARACTER  IN  LA  (2.X)  THEN  JUMP  TO  THIS  POSITION.   IDEN 

OTWERWISE  EXIT,  WITH  IDENT  =  45.  IDEN 

lA  (2,X)   THIS  IS  THE  MATCH  CHARACTER.  IDEN 

lA  (3.X)   WHEN  A  MATCH  OCCURS  THIS  IS  ThE  END  CODE,  IDEN 

=  -   THIS  MAY  BE  THE  END  OF  THE  STRING.  HOWEVER.    IDEN 

IT  COULD  CONTINUE  TO  A  NEW  VALUE.  IDEN 

IF  THE  NEXT  CHARACTER  DOES  NOT  MATCH  USE    IDEN 

ThE  ABSOLUTE  VALUE.  IDEN 

=  0   CONTINUE  TO  CHECK  FOR  FURTHER  MATCHES  IDEN 

=  ♦   THIS  IS  THE  END  OF  THE  STRING  USE  THIS  VALUE.  IDEN 

COMMON   /ALL/   ICHARS.  lOOLLAR.  lERROR,  INNUM  (2.  50).  IPOINT.    IDEN 

IPROG.  ISNUM.  ITYPE*  19999.  KFORM  (100),  KFOUT  (3,  100),  KSNUM  IDEN 


(2,  400),  LCARO  (80).  LCHARS,  LFOUT  (1000),  LSTATE  (2000),  IDEN 
LWOROS,  NAME  (4),  NCARDS,  XXXX,  NFORMN,  NFOUT.  NKFORM,  NOUTS,  IDEN 
NPUSH,  NS14UMC,  NSTATN,  NUMBER  (7).  NUMIN,  NUMK,  NVALUE,  STRING  IDEN 
(2,  100)  IDEN 

COMMON   /DATA/   C,  END,  H,  IBLANK,  lEOF,  INTEGER  (10),  IPUNCT 
(11),  ICOUNT  (2,  4),  LUIN,  LUOUT,  LUSTATE,  MFOUT,  MLCHAHS, 
MNFORM,  MNSTATE,  NCARC,  NMAX,  NUMMAX,  PROGRAM  (7),  RETURN, 
STAR,  X 


DIMENSION    lA  (3.270),  IB  (3.78). 
(3,70),  IF  (3.12),  NNEXT  (2) 
(IA(1),  le(l)) 
(IA(235),  IC(1>) 
(IA(424),  10(1)) 
(IA(565),  IE(1)) 
(IA(775).  IF(1)) 
9.  IHB,  0,  0,  IHL,  0, 
0,  0,  IHA,  0,  0,  IHT, 
IHM.  0.  0.  IHP, 
15,  IHD,  0,  0, 


IC  (3,63),  ID  (3.47),  IE 


EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EOUIVA&ENCE 

DATA     IB  / 

0.  0.  IHO 

IHO,  0,  0 

16,  IH  , 

IHL,  0,  0 

0,  IHI,  0 

0,  0,  IHU 

IHO,  0,  0 

0,  IHG,  0 

IHO,  0.  0 

-  23.  IH 

IHR.  0.  0 

0,  IHL,  0 

IHR,  0,  0 

0,  IHE.  2 

DATA     IC 

0.  0,  IHN 

IHS,  0,  0 

0,  IHF,  0 

0,  0,  1H( 

IHC,  0.  3 

4,  IHM,  0 

IHL,  0,  0 

0,  IHN,  0 


0,  IHO.  0,  0,  IHC,  0,  0,  IHK, 
0.  0,  IHA,  4,  8,  IHC,  0,  0, 
0,  0,  IHL,  0,  0.  IHE,  0,  0,  IHX,  0, 
IHO,  0,  0,  IHU,  0,  0,  IHB,  0,  0. 


IHE.  0.  0.  IHP,  0,  Oi 

0.  IHS,  0,  0,  IHI,  Oi 
0,  0,  1HN< 

IHN,  3,  e< 

0,  1HE«  0,  0,  IHR,  0. 

IHG,  0,  0,  IHI,  0,  0, 


IHR,  0.  0,  IHE,  0,  0,  IHC,  0, 
0,  IHO,  0,  0,  IHN,  0,  8,  IHF, 


IHPi 


0,  0,  IHC,  0,  0,  IHT,  0,  0.  IHI,  0,  0, 
IHI.  0.  0,  IHN,  0,  0,  IHT.  0,  0,  IHE.  Oi 
-  15,  IH  ,  0,  8.  IHL,  0,  0, 
IHC,  0,  0,  IHA,  0,  0,  IHL,  0< 
IHR,  0,  0,  IHO,  0,  0.  IHG,  0,  0, 


IDEN 
IDEN 
IDEN 
IDEN 
IDEN 
IDEN 
IDEN 
IDEN 
IDEN 
IDEN 
IDEN 
IDEN 
IDEN 
IDEN 
IDEN 
IDEN 
IDEN 
IDEN 
IDEN 
IDEN 
IDEN 
IDEN 


IHA.  0,  0,  IHM,  1,  5,  IHR,  0.  0,  IHE.  0.  0.  IHA,  0.  IDEN 


-  35, 
IHO.  0 


IH  .  0.  0.  IHS,  0,  0,  IHU,  0.  0,  IHB,  0,  0, 
>    0.  IHU.  0.  0.  IHT.  0,  0,  IHI,  0,  0,  IHN.  0. 


6,  IHAi 
23,  21i 
IHP.  Oi 


0,  0,  IHS,  0,  0,  IHS,  0,  0,  IHI.  0.  0.  IHG, 
IHB.  0 
0.  IHA 


IDEN 
IDEN 

IDEN 
IDEN 


IHC,  0.  0,  IHK,  0,  0,  IDEN 
0,  IHE,  40.  0.  IHU,  O.IDEN 


8,  IHA,  0,  0 

0.  0.  IHC,  0 

0,  IHF,  0,  0,  IHE,  0,  0,  IHR,  0,  3,  IHI,  0,  0.  IHN.  IDEN 
30,  0,  IHO,  0,  0,  IHU.  0,  0,  IHT,  0,  0,  1H(,  31,  20, IDEN 

IHA,  0,  0,  IHL,  0,  0,  IHL.  22,  0,  IHO.  0,  9,  IHM,  0,ICEN 

0,  IHO,  0,  0,  IHN,  -  6,  0,  IH/,  5,  0,  IHP,  0,  0,    IDEN 

IHE,  0,  0,  IHX,  9,  0,  IHN,  0,  0,  IHT.  0.  0.  IHI.  0,  IDEN 

0,  IHU,  0,  0,  IHE,  24,  23.  IHD,  0«  3.  IHA,  0,  0,     IDEN 


10 
20 
30 
40 
50 
60 
70 
80 
90 
100 
110 
120 
130 
140 
150 
160 
170 
180 
190 
200 
210 
220 
230 
240 
250 
260 
270 
280 
290 
300 
310 
320 
330 
340 
350 
360 
370 
380 
390 
<>00 
410 
<»20 
430 
440 
450 
460 
470 
480 
490 
500 
SIO 
520 
530 
540 
550 


n 
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60 


65 


70 


75 


8U 


85 


90 


9b 


100 


105 


no 


9 

IHT.  Ot  U«  IHA.  16.  6.  IHE.  0»  Ot  IHC*  0*    0«  IHO.  0«  0.  1HD«  0 

iIOEN  560 

9 

0.  IHE.  0.  0.  1H(.  32.  U.  IHI.  0.  0.  IHM.  0,  0.  IHEt  0.  0.  IHN 

iIDEN  570 

9 

0«  U«  IMS.  0.  0.  IHIt  0  / 

lOEN  580 

DATA     ID  /  0«  IHOt  0«  0.  IHNt  7«  Ot  IHO.   -  18«  0.  IHU.  Ot  Ot 

IDEN  590 

1 

iHBt  Ot  Ot  IHLt  Ot  Ot  iHEt  lOt  33t  IHEt  Ot  14t  IHNt  Ot  5t  IHCt 

IDEN  600 

2 

Ot  Ot  IHUt  Ot  Ot  IHOt  Ot  Ot  IHEt  Ot  Ot  lH(t  33t  5t  IHDt   -  Att 

IDEN  610 

3 

Ot  IHFt  Ot  Ot  IHIt  Ot  Ot  IHLt  Ot  Ot  IHEt  3dt  Ot  IHTt  Ot  Ot  IHR 

.IDEN  620 

4 

Ot  Ot  iHYt  Jbt  lit  iHOt  Ot  Ot  iHUt  Ot  Ot  IHIt  Ot  Ot  IHVt  Ot  Ot 

lOEN  630 

5 

IHAt  Ot  Ot  IHLt  Ot  Ot  IHEt  Ot  Ot  IHNt  Ot  Ot  IHCt  Ot  Ot  IHEt  Ot 

IDEN  640 

6 

Ot  lH(t  15t  Ot  IHXt  Ot  Ot  IHTt  Ot  Ot  IhEt  U.  Ot  Ihrtt  Ot  Ot  IHN 

.IDEN  650 

7 

Ot  Ot  IHAt  Ot  Ot  IHLt  et  7t  IHFt  Ot  Ot  IHOt  Ot  Ot  IHRt  Ot  Ot 

IDEN  660 

U 

iHMt  Ot  Ot  IHAt  Ot  Ot  IHTt  Ot  Ot  lH(t  17  / 

IDEN  670 

DATA     IE  /  St  IHGt  Ot  Ot  IHOt  Ot  Ot  IHTt  Ot  Ot  IHOt   -  20t  Ot 

IDEN  680 

1 

lH(t  19t  9t  IHIt  Ot  2t  IHFt  Ot  Ot  lH(t  21t  Ot  IHNt  Ot  Ot  IHTt 

IDEN  690 

2 

Ot  Ot  IHEt  Ot  Ot  IHGt  Ot  Ot  IHEt  Ot  Ot  IHR.  lit  7t  IHLt  Ot  Ot 

IDEN  700 

3 

IHOt  Ot  Ot  IHGt  Ot  Ot  IHIt  Ot  Ot  IHCt  Ot  Ot  IHAt  Ot  Ot  IHLt  12 

.IDEN  710 

<« 

8t  IhNt  Ot  Ot  IHAt  Ot  Ot  IHMt  Ot  Ot  IHEt  Ot  Ot  IHLt  Ot  Ot  IHIt 

IDEN  720 

5 

Ot  Ot  IHSt  Ot  Ot  IHTt  43t  20t  IHPt  Ot  '♦t  IHAt  Ot  Ot  IHUt  0.  Ot 

IDEN  730 

6 

IHSt  Ot  Ot  IHE  t  42t  lit  IHRt  Ot  7t  IHEt  Ot  Ot  IHCt  Ot  Ot  IHIt 

IDEN  740 

7 

Ot  Ot  IHSt  Ot  Ot  IHlt  Ot  Ot  IHOt  Ot  Ot  IHNt  14t  Ot  IHIt  Ot  Ot 

IDEN  750 

ti 

IHNt  Ot  Ot  IHTt  27t  Ot  IHUt  Ot  Ot  IHNt  Ot  Ot  IHCt  Ot  Ot  IhHt 

IDEN  760 

9 

29t  lAt  iHRt  0.  Ot  IHEt  Ot  4t  IHAt  Ot  2t  IHOt   -  26t  Ot  lH(t 

IDEN  770 

9 

25.  0.  IHLt  13t  4t  IHTt  Ot  Ot  IHUt  Ot  Ot  IHRt  Ot  Ot  IHN.  36.  0 

.IDEN  780 

9 

iHWt  Ot  Ot  IHIt  Ot  Ot  IHNt  Ot  Ot  IHDt  39t  <«  t  IHSt  Ot  Ot  IHT.  0 

.IDEN  790 

9 

0.  IHO.  0.  0.  iHPt  34t  5t  IHTt  Ot  0.  IHYt  Ot  Ot  IHPt  0  / 

IDEN  800 

DATA     IF  /  Ot  IHEt  Ot   -  15<tt  IH  t  Ot  <•  t  IHUt  Ot  Ot  IhSt  Ot  Ot 

IDEN  810 

1 

IHEt  Ot  Ot  lH(t  37t  Ut  IHtat  Ot  Ot  IHRt  Ot  Ot  IHIt  Ot  Ot  IHTt  0 

tIDEN  820 

2 

Ot  IHEt  Ot  Ot  lH(t  28  / 

IDEN  830 

DATA     NNEXT  /  It  79  / 

IDEN  840 

ISTART   =   IPOINT 

IDEN  850 

NEXT   =   NNEXT  (N) 

IDEN  860 

GO  TO  1020 

IDEN  870 

1000 

NEXT   =   NEXT  ♦  1 

IDEN  880 

C     ADVANCE  TO  THE  CHAHACTER  CF  THE  LIST  ISTATE. 

IDEN  890 

IPOINT   =   IPOINT  ♦  1 

IDEN  900 

1010 

IF  (IPOINT  .GT.  ICHARS)   GO  TO  1100 

IDEN  910 

1020 

IF  (LSTATECIPOINT)  .NE.  IBLANK)   GO  TO  1030 

IDEN  920 

C    SUSPHESS  ANY  BLANKS. 

IDEN  930 

CALL  SHIFTL  (IBLANK.  IPOINT.  ICHARS.  LSTATE(l)) 

IDEN  940 

GO  TO  1010 

IDEN  950 

C    NOta  CHECK  FOH  A  CHAKACTEK  MATCH. 

IDEN  960 

C      1 

F  ALHEAOY  PAST  USE  THE  DEFAULT  TERMINATION.  IDENT  =  45. 

IDEN  970 

1030 

IF  (LSTATE(IPOINT)  .LT.  IA(2tNEXT))   60  TO  1100 

IDEN  980 

IF  (LSTATE(IPOINT)  .GT.  IA(2tNEXT))   GO  TO  lOSO 

IDEN  990 

C    MATCH  CONOITON. 

IDENIOOO 

C     SEEK  THE  NEXT  ACTION. 

IDENIOIO 

C 

=  -  SEARCH  FOR  POSSIBLE  FURTHER  ACTION. 

IDEN1020 

C 

=  0  CONTINUE. 

IDEN1030 

C 

=  ♦  DONE. 

IDEN1040 

10^0 

IF  (IA(3.NEXT))    1060.  lOOOt  1090 

I0EN1050 

C     JUMP  TO  THE  NEXT  LEVEL   CHECK  CHARACTER.  00  NOT  ADVANCE  IPOINT. 

I0EN1060 

C 

=  U  DONE. 

IDEN1070 

c 

=  ♦  OH  -  JUMP  TO  THIS  LOCATION  IN  lA(I.NEXT)   ♦  NEXT. 

IOEN1080 

lObO 

IF  (lA(ltNEXT)  .EQ.  0)   CO  TO  1100 

IDEN1090 

NEXT   =   lA  (it  NEXT)  ♦  NEXT 

lOENllOO 
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115 


120 


125 


130 


00  TO  1030 
C     IF  NEGATIVE.  THERE  MAY  BE  ADDITIONAL  CHARACTERS,  IF  NOT 
C     ALUE  OF  lA  (3, NEXT) 

1060   lOENT   =    -  lA  (3»  NEXT) 
C     ADVANCE  TO  fHE  CHARACTER  OF  THE  LIST  ISTATE. 
IPOINT   =   IPOINT  ♦  1 
1070   IF  (IPOINT  .GT.  ICHARS)   GO  TO  9999 

IF  (LSTATE(IPOINT)  .NE.  IBLANK)   GO  TO  1080 
C    SUPPRESS  ANY  BLANKS. 

CALL  SHIFTL  (IbLANK,  IPCINT*  ICHARS,  LSTATE(l)) 
GO  TO  10  70 
1080   NEXT   =   NEAT  +1 
C    NOW  CHECK  FOR  A  CHARACTER  MATCH. 

IF  (LSTATE(IPOINT)  .EU.  IA(2,NEXT))   GO  TO  10^0 
GO  TO  9999 
C     IF  POSITIVE,  WE  ARE  ALL  CONE. 
1090   IDENT   =   lA  (3,  NEXT) 

IPOINT   =   IPOINT  ♦  1  • 

GO  TO  9999 
C     A  REPLACEMENT  STATEMENT  WAS  APPARENTLY  DETECTED. 
1100   IPOINT   =   ISTART 

IDENT   =  'tb 
9999   RETURN 
END 


lOENUlO 
TAKE  THIS  VICEN1120 
IDEN1130 
IDEN1140 
IDEN1150 
IDEN1160 
I0EN1170 
IDENlieO 
IDEN1190 
ICEN1200 
I0EN1210 
1DEN1220 
IDEN1230 
IDENI2«,0 
ICEN1250 
IDEN1260 
10EM270 
IDEN1280 
IDEN1290 
IDEN1300 
ICEN1310 
IDEN1320 
IDENI330 
IDENU'^O 
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bUBROUTINE   IFSPACE  CDC  6600  K TN  V3.0-P355  0PT=1 

SUbHOUTINE   IFSPACE 
C 

C    THIS  MOUTINE  COMPLETES  THE  SPACING  WITHIN  THE  IF  STATEMENTS. 
C 

COMMON   /ALL/   ICHAHS*  IDOLLAH,  lEHROR.  INNUM  (2.  50) t  IPOIKT. 

1  IPROG*  ISNUM,  ITYPE.  I9999»  KFORM  (100).  KFOUT  (3.  100).  KSNUM 

2  (2.  400).  LCARD  (80).  LCHARS.  LFOUT  (1000).  LSTATE  (2000). 

3  LWOftOS.  NAME  (A),  NCARDS.  NEXT.  NFORMN,  NFOUT.  NKFORM.  NOUTS.  ir^r  ou 
NPUSH.  NSNUMC.  NSTATN.  NUMBER  (7).  NUMIN,  NUMK,  NVALUE.  STRING  IFSP  90 
(2.  100)  IFSP  100 

COMMON   /DATA/   C.  END.  H,  IBLANK,  lEOF.  INTEGER  (10).  IPUNCT 

1  (11).  ICOUNT  (2.  4).  LUIN,  LUOUT,  LUSTATE.  MFOUT.  MLCHARS, 

2  MNFORM.  MNSTATE.  NCARC.  NMAX.  NUMMAX.  PROGRAM  (7).  RETURN. 


4 
10  5 


2 

3    STAR.  X 
15  C 

C    FIND  THE  FIRST  (  -  IPUNCT  (3) 
LOGICAL      CHECK 

LLOWER   =   ISCANL  (IPUNCT(3).  11.  LCHARS.  LSTaTE(I)) 
C    FIND  THE  MATCHING  )  -  IPUNCT  (4) 
20  LUPPER   =   MATCH  (LLOWEH.  LCHARS.  LSTATE(l)) 

C    FIND  THE  FIRST  .  -  IPUNCT  (7) 

IPFIRST   =   ISCANL  (IPUNCT(7).  LLOWER  ♦  1.  LCHARS.  LSTATE(l)) 
IF  (IPFIRST  .Gt.  LUPPER)   GO  TO  9999 
C    FIND  THE  NEXT   .  -  IPUNCT  (7) 
25  1000   IPNEXT   =   ISCANL  (IPUNCT(7).  IPFIRST  ♦  1.  LCHARS.  LSTATE(l)) 

IF  (IPFIRST  .GE.  LUPPER)   GO  TO  9999 
IF  (IPNEXT-IPFIRST  .GT.  4)   GO  TO  1080 
IF  (IPNEXT-IPFIRST-3)    1080.  1010.  1060 
C 
30  C    2   CHARACTER  SPACING.  IS  IT  EQ.  GE.  GltLE.  LT.  NE.  OR. 

1010   IF  (LSTATE(1PFIRST+1)  .EO.  IHE)   GO  TO  1020 
IF  (LSTATE(IPFIRST»1)  .EQ.  IHG)   GO  TO  1030 
IF  (LSTATE(IPFIRST*1)  .EQ.  IHL)   GO  TO  1030 
IF  (LSTATE(IPFIRST»1)  .EQ.  IHN)   GO  TO  1040 
35  IF  (LSTATE(IPFIRST*1)  .EQ.  IHO)   GO  TO  1050 

GO  TO  1080 
C 
1020   IF  (LSTATE(IPFIRST*2)  .EQ.  IHQ)   GO  TO  1070 
60  TO  1080 
40  C 

1030   IF  (LSTATE(IPFIRST*2)  .EQ.  IHT)   GO  TO  1070 
1040   IF  (LSTATE(IPFIRST*2)  .EQ.  IHE)   GO  TO  1070 
GO  TO  1080 
C 
45  1050   IF  (LSTATE(IPFIRST*2)  .EQ.  IHR)   GO  TO  1070 

GO  TO  1080 
C 

C    3   CHARACTER  SPACING.  IS  IT  AND  OR  NOT. 
1060   IF  (CHECK(3HAND.3.IPFIRST*I .IPNEXT.LSTATE(l) .IP) )   GO  TO  1070 
50  IF  (  .NOT.  CHECK (3HN0T. 3. IPFIRST+1. IPNEXT. LSTATE (1) .IP) )   GO  TO 

1    1080 
C 

C    YES.  INSERT  SURROUNDING  SPACES. 
1070   CALL  INSERT  (IBLANK.  IPNEXT  ♦  1.  LCHARS.  LSTATE(l).  1) 
55  CALL  INSERT  (IBLANK,  IPFIRST.  LCHARS.  LSTATE(l).  1) 

IPNEXT   =   IPNEXT  ♦  2 
1080   IPFIRST   =   IPNEXT 
GO  TO  1000 
C 
60  9999   RETURN 

END 


06/25/75   12. 

55.39 

IFSP 

10 

IFSP 

20 

IFSP 

30 

IFSP 

40 

IFSP 

50 

IFSP 

60 

IFSP 

70 

IFSP 

80 

IFSP 

90 

IFSP 

100 

IFSP 

110 

IFSP 

120 

IFSP 

130 

IFSP 

140 

IFSP 

150 

IFSP 

160 

IFSP 

170 

IFSP 

180 

IFSP 

190 

IFSP 

200 

IFSP 

210 

IFSP 

220 

IFSP 

230 

IFSP 

240 

IFSP 

250 

IFSP 

260 

IFSP 

270 

IFSP 

280 

IFSP 

290 

IFSP 

300 

IFSP 

310 

IFSP 

320 

IFSP 

330 

IFSP 

34  0 

IFSP 

350 

IFSP 

360 

IFSP 

370 

IFSP 

38  0 

IFSP 

390 

IFSP 

400 

IFSP 

410 

IFSP 

420 

IFSP 

430 

IFSP 

440 

IFSP 

450 

IFSP 

460 

IFSP 

470 

IFSP 

480 

IFSP 

490 

IFSP 

500 

IFSP 

510 

IFSP 

520 

IFSP 

530 

IFSP 

540 

IFSP 

550 

IFSP 

560 

IFSP 

570 

IFSP 

580 

IFSP 

590 

IFSP 

600 

IFSP 

610 
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10 


15 


20 


25 


30 


35 


40 


45 


SUBROUTINE   INSERT  (NEW*  ISTART<  ISTOP,  LIST.  N)  INSE 

C     This  ROUTINE  INSERTS  INTO  THE  DATA  STRING  LIST  THE  N  CHARACTERS  PaSINSE 

C       THRU  NEW»  START  AT  POSITION  ISTART.   ISTOP  IS  INCREASED  BY  N.     INSE 

COMMON   /ALL/   ICHARS.  lOOLLAR.  lERROR.  INNUM  (2»  50).  IPOINT.    INSE 

IPROGt  ISNUM»  ITYPE.  19999.  KFORM  (100).  KFOUT  (3.  100).  KSNUM  INSE 

(2.  400).  LCARD  (80).  LCHARS.  LFOUT  (1000).  LSTATE  (2000).      INSE 

LWORDS,  NAME  (4),  NCARDS.  NEXT.  NFORMN.  NFOuT.  NKFORM.  NOUTS.   INSE 

NPUSH.  NSNUMC.  NSTATN.  NUMBER  (7).  NUMIN.  NUMK.  NVALUE.  STRING  INSE 


1 


1000 
1010 
1020 
1030 


(2.  100) 
COMMON   /DATA/   C.  END.  H.  IBLANK.  lEOF.  INTEGER  (10).  IPUNCT 

(11).  ICOUNT  (2.  4).  LUIN.  LUOUT.  LUSTaTE.  MFOUT.  MLChARS. 

MNFORM.  MNSTATE.  NCARD.  NMAX.  NUMMAX.  PROGRAM  (7).  RETURN. 

STAR.  X 
DIMENSION    LIST  (1),  NEW  (1).  NEWTEMP  (100) 
NN   =   N 

IF  (NN  .LE.  0)   GO  TO  9999 
IF  (NUMIN  .LE.  0)   GO  TO  1010 

DO  1000   J   =   1.  NUMIN 

IF   (ISTART  .LT.  INNUMd.  J))   INNUM  (1.  J)   =   INNUM  (1.  J)  ♦ 
NN 

CONTINUE 
DECODE  (NN. 

DO  1030   I 

CALL  SHIFTR 


1040 


1050 


9999 

10 
20 


10.  NEW  (D) 

=   1.  NN 

(NEWTEMP(I),  ISTART 
ICHARS   =   ICHARS  ♦  NN 
IF   (lOOLLAR  .GT.  0)   ICOLLAR   = 
60  TO  9999 
ENTRY  INSERTN 

ENCODE  (10.    20.  NEWTEMP  (100)) 
DECODE  (5.    10.  NEWTEMP  (100)) 
NN   =   5 
IF 
IF 
NN 
00 


(NEWTEMP  (I).  1=1.  NN) 


1.  ISTOP.  LIST(l)) 


IDOLLAR  ♦  NN 


(N  .GE.  4)   GO  TO   1020 
(NEWTEMP  (2)  .NE.  IBLANK) 

1 

=  2.  NN 
=   NEWTEMP  (I*  1) 


NEW  (1) 
(NEWTEMP 


60  TO  1020 


(I).  1=1.  5) 


=   NN  - 
1050   I  = 

NEWTEMP  (I)   = 

60  TO   1040 

ENTRY  INSERTS 

NN   =   N 

IF  (NN  .LE.  0) 

GO  TO  1010 

RETURN 


GO  TO  9999 


FORMAT 
FORMAT 

END 


lOOAl 
15  ) 


INSE 
INSE 
INSE 
INSE 
INSE 
INSE 
INSE 
INSE 
INSE 
INSE 
INSE 
INSE 
INSE 
INSE 
INSE 
INSE 
INSE 
INSE 
INSE 
INSE 
INSE 
INSE 
INSE 
INSE 
INSE 
INSE 
INSE 
INSE 
INSE 
INSE 
INSE 
INSE 
INSE 
INSE 
INSE 
INSE 
INSE 
INSE 
INSE 


10 

20 

30 

40 

50 

60 

70 

80 

90 

92 

94 

96 

98 

100 

110 

120 

130 

140 

150 

160 

170 

180 

190 

200 

210 

220 

230 

240 

2S0 

260 

270 

272 

273 

276 

280 

283 

286 

290 

300 

310 

320 

330 

340 

350 

360 

370 

380 


21 


FUNCTION     ISCANR  COC  6600  FTN  V3.0-P355  0PT=1   06/25/75   12.55.39. 

FUNCTION   ISCANR  <L00K4.  ISTARTt  ISTOP.  LIST) 
C     THIS  FUNCION  SCANS  A  DATA  LIST  FOR  A  SPECIFIC  CHARACTER 
C       AND  RETURNS  THE  LOCATION  IF  FOUND. 
C     SCAN  FROM  THE  RIGHT  (LAST). 
5  DIMENSION    LIST  (1) 

I   =   ISTOP 
1000   IF  (I  .LT.  ISTART)   GO  TO  1020 

IF  (LIST(I)  .EO.  LOOK-*)   GO  TO  1020 
1   =   1-1 
10  GO  TO  1000 

C 

ENTRY  ISCANL 
C     SCAN  FROM  THE  LEFT  (FIRST). 
I   =   ISTART 
15  1010   IF  (I  .GT.  ISTOP)   GO  TO  1020 

IF  (LIST(I)  .EQ.  L00K4)   GO  TO  1020 
1   =   1*1 
GO  TO  1010 
1020   ISCANR   =   I 
20  9999   RETURN 

END 


ISCA 

10 

(LOOKA).  ISCA 

20 

ISCA 

30 

ISCA 

40 

ISCA 

50 

ISCA 

60 

ISCA 

70 

ISCA 

80 

ISCA 

90 

ISCA 

100 

ISCA 

110 

ISCA 

120 

ISCA 

130 

ISCA 

140 

ISCA 

150 

ISCA 

160 

ISCA 

170 

ISCA 

180 

ISCA 

190 

ISCA 

200 

ISCA 

210 
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bUBROUTINE   KF  COC  6600  FTN  V3.0-P355  0PT=1   06/215/75   12.55. 39. 

SUBROUTINE   KF  (NSTN)  KF  10 

C     THIS  ROUTINE  CATALOGS  THE  FORMAT  STATEMENT  NUMBER  IN  THE  ORDER  OF  KF  20 

C       THEIR  USE  IN  THE  ROUTINE.  KF  30 

C  KF  40 

5  COMMON   /ALL/   IChARS,  IDOLLARt  lERROR,  INNUM  (2.  50).  IPOINT.  KF  50 

1  IPROG»  ISNUM.  ITYPE.  I999y»  KFORM  (100).  KFOUT  (3.  100)»  KSNUM  KF  60 

2  (2.  400).  LCARD  (80)»  LCHARS.  LFOUT  (1000).  LSTATE  (2000).  KF  70 

3  LWOROS.  NAME  (4).  NCARDS.  NEXT,  NFORMN.  NFOUT,  NKFORM.  NOUTS.  KF  80 

4  NPUSh,  NSNUMC.  NSTATN.  number  (7).  NUMIN.  NUMK.  NVALUE.  STRING  KF  90 
10          '       5    (2.  100)  KF  100 

COMMON   /DATA/   C.  ENO.  H.  IBLANK.  lEOF.  INTEGER  (10).  IPUNCT  KF  110 

1  (11).  ICOUNT  (2.  4).  LUIN.  LUOUT.  LUSTATE.  MFOUT.  MLChARS.  KF  120 

2  MNFORM,  MNSTATE.  NCAHC.  NMAX.  NUMMAX.  PROGRAM  (7).  RETURN,  KF  130 
J    STAR.  X  KF  140 

15  IF  (NFORMN  .LE.  0)   GO  TO  1010  KF  150 

C     CHECK  IF  THIS  FORMAT  STATEMENT  NUMBER  IS  ALREADY  CaTELOGED.  KF  160 

DO  1000   J   =   1.  NFORMN  KF  170 

IF  (KFORM(J)  .EO.  NSTN)   GO  TO  1020  KF  180 

1000     CONTINUE  KF  190 

20  C     CATELOG  at  the  end  OF  THE  ARRAY.  '  KF  '  200 

lOlQ   NFORMN   =   NFORMN  ♦  1  KF  210 

IF  (NFORMN  .GT.  MNFORM)   GO  TO  1030  KF  220 

KFORM  (NFORMN)   =   NSTN  KF  230 

1020   GO  TO  9999  KF  240 

25  1030   PRINT    10.  MNFORM.  (LSTATE(l).  1=1.  LCHARS)  KF  250 

9999   RETURN  KF  260 

C  KF  270 

10   FORMAT   (   »0THE  ARRAY  (^FORM)  IS  FULL.   THE  NUMBER  OF  FORMAT  ST»KF  280 

1    «ATEMENT  NUMBERS  CATALOGED  BY  THEIR  ORDER  OF  FIRST  USE  EXCEEDE^KF  290 

30  2    «D  «  15  *0N  STATEMENT*  //  (20X.  lOOAl)  )  KF  300 

C  KF  310 

ENO  KF  320 


23 
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KLIST 
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15 


20 


25 


LOGICALFUNCTION   KLIST  (IP,  NS 
C     THIS  FUNCTION  RECOHDS  THE  VALUE 
C       STATEMENT  NUMBERS. 

COMMON  /ALL/  ICHAHS,  IDOLLAR 
1  IPROGf  ISNUM,  ITYPE.  19999. 
a  (2,'400)»  LCARO  (80)  ♦  LCHARS 
3  LWOROS.  NAME  (^)»  NCAKOS,  NE 
H  NPUSH.  NSNUMC»  NSTATN.  NUMBE 
b    (2.  100) 

COMMON   /DATA/   C,  END»  H.  IBL 

1  (11),  ICOUNT  (2,  ^),  LUIN,  L 

2  MNFORM,  MNSTATE,  NCARC ,  NMAX 


TN) 

AND  THE  POSITION  OF  THE  INTERNAL 


lERROR,  IN 
KFORM  (100), 
,  LFOUT  (100 
AT,  NFORMN 
R  (7),  NUMIN 

ANK,  lEOF,  I 
UOUT,  LUSTAT 
,  NUMMAX,  PR 


NUM  (2,  50)»  IPOINT, 

KFOUT  (3,  100),  KSNUM 
0),  LSTATE  (2000), 
NFOUT,  NKFORM,  NOUTS, 
NUMK,  NVALUE,  STRING 

NTEGER  (10),  IPUNCT 
E,  MFOUT,  MLCHARS, 
OGRAM  (7),  RETURN, 


STAR,  X 
KLIST   = 


.FALSE. 


IF  (NUMIN  .GE.  NUMMAX  .OR.  NUMIN  .LT.  0)   GO  TO  1000 


1000 
9999 

10 


NUMIN  = 
INNUM  (1 
INNUM  (2 
KLIST  = 
GO  TO  9999 
PRINT 
RETURN 


NUMIN  " 
NUMIN) 
NUMIN) 
.TRUE. 


1 


IP 
NSTN 


10,  NUMMAX,  (LSTATE(I),  1=1,  LCHARS) 


FORMAT   (   »OTHE  ARRAY  (INNUM) 
^STATEMENT  NUMBERS  EXCEEDED 
) 

END 


IS  FULL.   T 
«  15  ''ON  STA 


HE  NUMBER  OF  INTERNAL 
TEMENT*  //  (20X,  lOOAl 


KLIS 

10 

KLIS 

20 

KLIS 

30 

KLIS 

^0 

KLIS 

50 

KLIS 

60 

KLIS 

70 

KLIS 

60 

KLIS 

90 

KLIS 

100 

KLIS 

110 

KLIS 

120 

KLIS 

130 

KLIS 

140 

KLIS 

150 

KLIS 

160 

KLIS 

170 

KLIS 

180 

KLIS 

190 

KLIS 

200 

KLIS 

210 

KLIS 

220 

KLIS 

230 

»KLIS 

24  0 

)KLIS 

250 

KLIS 

260 

KLIS 

270 

KLIS 

260 
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FUNCTION 


KO 


COC  6600  FTN  V3.0-P355  OPTxl   06/25/75   12.55,39. 


10 


15 


20 


25 


30 


35 


40 


LOCICAUFUNCTION  KO  (NST 
C  THIS  FUNCTION  CATELOGS  THE 
C       IN  THE  ARRAY  KFOUT . 

COMMON   /ALL/   ICHARS.  I 

1  IPROG.  ISNUM»  ITYPE*  I 

2  (2«  400) «  LCARD  (80) > 

3  LWORDS.  NAME  (^),  NCAR 

4  NPUSH»  NSNUMC*  NSTATN» 

5  (2.  100) 

COMMON   /DATA/   C»  END. 

1  (11).  ICOUNT  (2.  4).  L 

2  MNFORM.  MNSTATE.  NCARC 

3  STAR.  X 

KO   =   .FALSE. 
IF  (NFOUT  .LE.  0) 
C     CHECK  IF  THIS  FORMAT  STATE 
DO  1000   J   =   1.  NFOU 
IF  (KFOUT(l.J)  .EQ.  NS 
1000     CONTINUE 
C     CATELOG  AT  THE  END  OF  THE 
1010   NFOUT 


N) 
LOCATION  OF  THE  FORMAT  STATEMENT  NUMBER 

DOLLAR.  lERROR.  INNUM  (2.  50).  IPOINT. 
9999.  KFORM  (100).  KFOUT  <3.  100).  KSNUM 
LCHARS.  LFOUT  (1000).  LSTATE  (2000). 
OS.  NEXT.  NFORMN.  NFOUT,  NKFORM.  NOUTS. 
NUMBER  (7).  NUMIN.  NUMK.  NVALUE.  STRING 

H.  IBLANK.  lEOF.  INTEGER  (10).  IPUNCT 
UIN.  LUOUT.  LUSTATE.  MFOUT.  MLCHARS. 
.  NMAX.  NUMMAX.  PROGRAM  (7).  RETURN. 


GO  TO  1010 

MENT  NUMBER  IS  ALREADY  CATELOGEO, 

T 

TN)   GO  TO  9999 

ARRAY. 


1020 


1030 


9999 


NFOUT  ♦  1 
IF  (NFOUT  .GT.  MNFORM) 
KFOUT  (1.  NFOUT)   =   NSTr 
KFOUT  (2.  NFOUT)   =   NEXl 
KFOUT  (3.  NFOUT)   =  IChl 
NEXT   =   NEXT  ♦  (ICHARS 
IF  (NEXT  .GT.  MFOUT)   GO 
KO   =   .TRUE. 
GO  TO  9999 

PRINT    10.  MNFORM.  (LSTATE(I).  1=1.  LCHARS) 
GO  TO  9999 

20.  MFOUT,  (LSTAl 
KFOUT  (2.  NFOUTl 

NFOUT  -  1 


PRINT 
NEXT 
NfOUT 
RETURN 


GO  TO  1020 
FN 
(T 
-ARS 

♦  9)  /  10 
TO  1030 


>TE(I).  1=1.  LCHARS) 
) 


10 


20 


FORMAT  (  »0THE  ARRAY  ( 
«ATEMENT  NUMBER  STORED 
<^0N  STATEMENT*  //  (20X 

FORMAT  (  »OTHE  ARRAY  ( 
«ATEMENT  WORDS  EX 
lOOAl)  ) 

END 


KFOUT)  IS  FULL.   THE  NUMBER  OF  FORMAT  ST 

IN  ARRAY  (KSNUM)  EXCEEDED  «  15 
.  lOOAl)  ) 

LFOUT)  IS  FULL.   THE  NUMBER  OF  FORMAT  ST 
CEEDED  «  15  «0N  STATEMENT*  //  (20X. 


KO 

10 

!SKO 

20 

KO 

30 

KO 

40 

1  KO 

50 

KO 

60 

KO 

70 

1  KO 

80 

KO 

90 

KO 

100 

KO 

110 

KO 

120 

KO 

130 

KO 

140 

KO 

150 

KO 

160 

KO 

170 

KO 

180 

KO 

190 

KO 

200 

KO 

210 

KO 

220 

KO 

230 

KO 

240 

KO 

250 

KO 

260 

KO 

270 

KO 

280 

KO 

290 

KO 

300 

KO 

310 

KO 

320 

KO 

323 

KO 

326 

KO 

330 

KO 

340 

«K0 

350 

KO 

360 

KO 

370 

»K0 

380 

KO 

390 

KO 

400 

KG 

410 

KO 

420 

25 


FUNCTION     MATCH  CL)C  6600  I- TN  V3.0-P355  0PT  =  1 

FUNCTION   MATCH  <IbTAKT.  ISTOP.  LIST) 
C     THIS  FUNCTION  FINOb  THE  CLOSING  ). 
C        ISTAWT       KNOWN  POSITION  OF  THE  FIKST  (. 

COMMON   /DATA/   C.  END.  H,  Ifc)LANt<,,  llOF ,     INTEGER  (10),  IPUNCT 
6  1     (11),  ICOUNT  {^,    ^),  LOIN,  LUOUT,  LUSTATE,  MFOUT,  MLCHARS, 

2  MNFOWM,  MNSTATE,  NCAHC,  NMAX,  NUMMAX,  PhOGKAM  (7),  RETURN, 

3  STAK,  X 
DIMENSION    LIST  (1) 
I^   =   13   =   ISTART  ♦  1 

10  C       13     POSITION  OF  NEXT  (. 

1000   13   =   ISCANL  (IPUNCT(3),  13.  ISTOP,  LIST(l)) 
C       I'*  POSITION  OF  NEXT  )  . 

14   =   MATCH   =   ISCANL  (IPUNCT(4),  14,  ISTOP,  LIST(l)) 
C     LAST  )  IS  FOUND  WHEN  NEXT  (  IS  TO  THE  RIGHT  OR  WHEN  ISTOP  HAS  BEEN  MATC  140 
IS  C       EXCEEDED. 

IF  (13  .6E.  14  .OR.  14  .GT.  ISTOP)   GO  TO  9999 
C     ACCROSS  bY  PAIRS. 

13  =   13  ♦  1 

14  =   14  ♦  1 
20                                          GO  TO  1000 

9999   RETURN 
END 


06/2b/7b 

12.5S.39 

MATC 

10 

MATC 

20 

MATC 

30 

MATC 

40 

MATC 

SO 

MATC 

60 

MATC 

70 

MATC 

80 

MATC 

90 

MATC 

100 

MATC 

110 

MATC 

120 

MATC 

130 

MATC 

140 

MATC 

150 

MATC 

160 

MATC 

170 

MATC 

180 

MATC 

190 

MATC 

200 

MATC 

210 

MATC 

220 
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FUNCTION 


NONR 
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10 


15 


20 


(NONR)  OR  FIRST 


FUNCTION   NONR  (L00KA»  ISTART,  ISTOP,  LIST) 
C     This  FUNCION  DETERMINES  ThE  LOCATION  OF  THE  LAST 
C        (NONL)  NONE  (LOOKA) 

C       CHARACTER  BETWEEN  ISTART  AND  ISTOP  IN  THE  DATA  STRING  LIST, 
C     SCAN  FROM  THE  RIGHT  (LAST). 

DIMENSION    LIST  (1) 

I   =   ISTOP 
1000   IF  (I  .LT.  ISTART)   GO  TO  1020 

IF  (LIST(I)  .NE.  LOOK^t)   GO  TO  1020 

1   =   1-1 

GO  TO  1000 

c 

ENTRY  NONL 
C     SCAN  FROM  THE  LEFT  (FIRST). 

I   =   ISTART 
1010   IF  (I  .GT.  ISTOP)   GO  TO  1020 

IF  (LIST(I)  .NE.  L00K4)   GO  TO  1020 

1   =   1*1 

GO  TO  1010 
1020  NONR  =  I 
9999   RETURN 

END 


NONR 

10 

NONR 

20 

NONR 

30 

NONR 

40 

NONR 

50 

NONR 

60 

NONR 

70 

NONR 

80 

NONR 

90 

NONK 

100 

NONR 

110 

NONR 

120 

NONR 

130 

NONR 

140 

NONR 

150 

NONR 

160 

NONR 

170 

NONR 

180 

NONR 

190 

NONR 

200 

NONR 

210 

NONR 

220 
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FUNCTION   NUMBS  (ISTART,  ISTOP.  LIST)  NUMb   10 

C     This  FUNCTION  EXAMINES  THE  STRING  LIST  STARTING  AT  ISTART  LOOKING  NUMb   20 

C       FOR  A  NUMERICAL  VALUE  WHICH  IF  FOUND  IS  RETURNED  AND  THE  LOCATIONNUMb   30 

C       SURPRESSED.  OTHERWISE  A  ZERO  IS  RETURNED.  NUMb  kO 

5  COMMON   /ALL/   ICHARSt  IDOLLAR.  lERROR,  INNUM  (2,  50) »  IPOINT,  NUMb   50 

1  IPROG»  ISNUM.  ITYPE.  19999»  KFORM  (100) »  KFOUT  (3.  100) t  KSNUM  NUMb   60 

2  (2»  ^00)1  LCARD  (80)»  LCHARS.  LFOUT  (1000).  LSTATE  (2000).  NUMb   70 

3  LWORDS,  NAME  (A).  NCAROS.  NEXT.  NFORMN.  NFOUT.  NKFORM,  NOUTS.  NUMB   80 
^         NPUSH.  NSNUMC.  NSTATN.  NUMBER  (7).  NUMIN,  NUMK,  NVALUE.  STRING  NUMB   90 

10  5    (2.  100)  NUMb  100 

COMMON   /DATA/   C.  END.  H.  IBLANK.  lEOF.  INTEGER  (10).  IPUNCT  NUMB  110 

1  (11).  ICOUNT  (2.  ^).  LUIN.  LUOUT.  LUSTATE.  MFOUT.  MLChARS.  NUMB  120 

2  MNFORM.  MNSTATE.  NCARC.  NMAX.  NUMMAX.  PROGRAM  (7).  RETURN.  NUMb  130 

3  STAR.  X  NUMb  1^0 
15                   DIMENSION    LIST  (1)  NUMb  150 

IS   =   ISTART  NUMb  160 

NUMBS   =   0  NUMb  170 

1000   IF  (IS  .GT.  ISTOP)   GO  TO  9999  NUMb  180 

IF  (LIST(IS)  .EQ.  IBLANK)   GO  TO  1030  NUMB  190 

20  DO  1010   I   =   1.  10  NUMb  200 

IF  (LIST(IS)  .EQ.  INTEGER(I))   GO  TO  1020  NUMb  210 

1010     CONTINUE  NUMb  220 

eO  TO  9^99  NUMb  230 

1020   NUMBS   =   NUMBS  «  10  ♦  I  -  1  NUMb  240 

25  1030   CONTINUE  NUMB  250 

CALL  SHIFTL  (IBLANK,  IS.  ISTOP.  LIST(l))  NUMb  260 

IChARS   =   KHARS  -  1  NUMB  270 

IF   (IDOLLAR  .GT.  0)   ICOLLAR   =   IDOLLAR  -  1  NUMB  280 

GO  TO  1000  NUMb  290 

30  9999   RETURN  NUMb  300 

END  NUMB  310 
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bUBKOUTINE   OUTFRM  OUTF   10 

C     This  ROUTINE  OUTPUTS  THE  FORMAT  STATEMENTS  IN  THE  ORDER  THEY  ARE  OUTK   20 

C       USED.  OUTF   30 

COMMON  /ALL/  ICHARSt  IDOLLAR,  lERROR.  INNUM  (2«  50) ♦  IPOINT.  OUTF  ^0 
5                1    IPROG.  ISNUM,  ITYPE*  19999*  KFORM  (100) »  KFOUT  (3.  100).  KSNUM  OUTF   50 

2  (2.  400)»  LCARO  (80).  LCHARS.  LFOUT  (1000).  LSTaTE  (2000).  OUTF   60 

3  LWORDS.  NAME  C).  NCARDS.  NEXT.  NFORMN.  NFOUT,  NKFORM.  NOUTS.  OUTF  70 
A  NPUSH.  NSNUMC.  NSTATN.  NUMBER  (7).  NUMIN.  NUMK.  NVALUE.  STRING  OUTF  80 
5    (2.  100)  OUTF   90 

10  COMMON   /DATA/   C.  END.  H.  IHLANK.  lEOF.  INTEGER  (10).  IPUNCT  OUTF  100 

1  (11).  ICOUNT  (2.  >*),    LUIN.  LUOUT.  LUSTATE.  MFOUT,  MLCHARS,  OUTF  HO 

2  MNFORM.  MNSTATE.  NCARC.  NMAX.  NUMMAX,  PROGRAM  (7).  RETURN.  OUTF  120 

3  STAR,  X  OUTF  130 
INTEGER      Al.  C.  FORMAT.  H  OUTF  140 

15  DATA     Al  /  2HA1   /  ,  FORMAT  /  6HF0RMAT   /  OUTF  150 

IF  (NFORMN  .LE.  0  .OR.  lERROR  .EQ.  999)   CO  TO  9999  OUTF  160 

LCHAR§   =   1  OUTF  170 

LSTATE  (1)   =   C  OUTF  180 

CALL  PUNCHIT  (0)  OUTF  190 

20  lERROR   =   999  OUTF  200 

DO  1240   J   =   1.  NFORMN  OUTF  210 

DO  1000   JJ   =   1.  NFOUT  OUTF  220 

IF  (KFORM(J)  .EC).  KFOUTd.JJ))   GO  TO  1010  OUTF  230 

1000       CONTINUE  OUTF  240 

2b  C     NOT  FOUND  INSERT  THE  DUMMY  FORMAT  STATEMENT.  OUTF  250 

PRINT    10.  KFORM  (J)  OUTF  260 

LCHARS   =   ICHARS   =   0  OUTF  270 

CALL  INSERTS  (IPUNCT(4).  1.  LCHARS.  LSTATE(l).  1)  OUTF  280 

CALL  INSERTS  (Al.  1.  LCHARS.  LSTATE(l).  3)  OUTF  290 

30  CALL  INSERTS  (IPUNCT(3).  1.  LCHARS.  LSTATE(l).  2)  OUTF  300 

GO  TO  1060  OUTF  310 

C     RETREVIE  THE  FORMAT  STATEMENT  FROM  THE  ARRAY  KFOUT.  OUTF  320 

1010     IN   =   KFOUT  (2.  JJ)  OUTF  330 

LCHARS   =   ICHARS   =   KFOUT  (3.  JJ)  OUTF  340 

35  NFOUT   =   NFOUT  -  1  OUTF  350 

'   00  1030   I   =   1.  3  OUTF  360 

IF  (NFOUT  .LT.  JJ)   GO  TO  1030  OUTF  370 

00  1020   JJJ   =   JJ.  NFOUT  OUTF  380 

1020         KFOUT  (I.  JJJ)   =   KFOUT  (I.  JJJ  ♦  1)  OUTF  390 

40  1030       KFOUT  (I.  NFOUT  ♦  1)   =   0  OUTF  400 

IPOINT   =   1  OUTF  410 

DO  1040   II   =   IN.  1000.  10  OUTF  420 

12   =   MINO  (IPOINT  ♦  99.  ICHARS)  OUTF  430 

IC   =   12  ♦  1  -  IPOINT  OUTF  440 

45  IF  (IC  .LE.  0)   GO  TO  1050  OUTF  450 

DECODE  (IC.    20,  LFOUT  (II))    (LSTATE  (I),  I=IPOINT.  12)  OUTF  460 

1040       IPOINT   =   IPOINT  ♦  100  OUTF  470 

C     COMPLETE   THE  FORMAT  STATEMENT.  OUTF  480 

1050     CALL  INSERTS  (IBLANK.  ICHARS  ♦  1.  LCHARS.  LSTATE(l).  1)  OUTF  490 

50  CALL  INSERTS  (IPUNCT(4),  ICHARS  +  1,  LChARS,  LSTATE(l),  1)  OUTF  500 

CALL  INSERTS  (IPUNCT(3),  1.  LCHARS,  LSTATE(l).  2)  OUTF  510 

1060     CALL  INSERTS  (FORMAT.  1.  LCHARS,  LSTATE(l).  8)  OUTF  520 

CALL  INSERTS  (IBLANK.  1.  LCHARS.  LSTATE(l).  2)  OUTF  530 

CALL  INSERTN  (J  *>  10.  1.  LCHARS,  LSTATE(l),  4)  OUTF  540 

55  II   =   18  OUTF  550 
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60 


65 


70 


75 


80 


es 


90 


95 


100 


105 


110 


C    START  HERE  TO  SPACE  OUT  THE  BALANCE  OF  THE  FORMAT  STATEMENT. 
1070     IF  (II  .GE.  LCHARS)   GO  TO  1240 
IS   =   II 
C    SEARCH  FOR  THE  FIRST  SPECIAL  CHARACTER, 

00  1090   II   =   ISt  LCHARS 
C    IS  THE  FIRST  SPECICAL  CHARACTER  A  / 

IF  (LSTATE(II)  .EQ.  IPUNCT(l))   60  TO  1200 
C    IS  THE  FIRST  SPECICAL  CHARACTER  A  . 

IF  (LSTATE(II)  .EQ.  IPUNCT(2))   GO  TO  1220 
C    IS  THE  FIRST  SPECICAL  CHARACTER  A  •  OR  A  * 
DO  1080   JJ   =   5.  11.  6 

IF  (LSTATE(II)  .EQ.  IPUNCT(JJ))   GO  TO  1170 
1080         CONTINUE 

IF  (LSTaTE(II)  .EQ.  H)   GO  TO  1100 
1090       CONTINUE 
GO  TO  1240 
C    NO  IT  IS  AN  H. 
C     IS  THIS  A  HOLERITH  FIELD 
1100     IPR   =   II  -  2 

DO  1110   I   =   1.  10 

IF  <INTEGER(I)  .EQ.  LSTATE ( I  I-l ) )   GO  TO  1120 
1110       CONTINUE 
C     NO.  REPEAT  THE   SEARCH 
II   =   II  ♦  1 
GO  TO  1070 
C    DETERMINE  THE  LENGTH  OF  THE  HOLERITH  FIELD. 
1120     N   =   I  -  1 

DO  1130   I   =   1.  10 

IF  (INTEGER(I)  .EQ.  LSTATE(II-2))   GO  TO  1140 
1130       CONTINUE 
GO  TO  1150 
1140     N   =   N  ♦  10  «  (I  -  1) 
IPR   =   IPR  -  1 

IF   (INTEGER(2)  .EQ.  LSTATEdl  -  3))   N   =   N  ♦  100 
IF   (N  .GE.  100)   IPR   =   IPR  -  1 
1150     IF  (LSTATE(IPR)  .EQ.  IBLANK)   GO  TO  1160 

CALL  INSERTS  (IBLANK.  IPR.  LCHARS.  LSTATEd).  1) 
II   =   II  ♦  1 
1160     ILAST   =   II  ♦  N 
IFIRST   =   II  ♦  1 
GO  TO  llbO 
C    INSERT  A  BLANK  BEFORE  AN  «  OR  #  AND  THEN  SKIP  TO  THE  NEXT  «  OR  *. 
1170     CALL  INSERTS  (IBLANK.  II.  LCHARS,  LSTATEd).  1) 
IFIRST   =   II  ♦  2 

ILA5T   =   ISCANL  dPUNCT(JJ).  IFIRST,  LCHARS.  LSTATEd)) 
1180     II   =   ILAST  ♦  1 
C    ALTER  THE  HOLERITH  FIELDS  TO  ASSURE  PROPER  OUTPUT  SPACING. 
DO  1190   I   =   IFIRST.  ILAST 
1190       LSTATE  d)   =   LSTATE  (I)  ♦  1 
IF  dl  .GE.  LCHARS)   GO  TO  1240 
IF  (LSTATEdl)  .EQ.  IFUNCTd))   GO  TO  1200 
IF   (LSTATEdl)  .EQ.  IPUNCT(2))   II   =   II  ♦  1 
GO  TO  1230 
C     INSERT  A  BLANK  BEFORE  THE  FIRST  AND  AFTER  THE  LAST  /. 
1200     CALL  INSERTS  (IBLANK,  II,  LCHARS,  LSTATEd),  1) 


OUTF  560 
OUTF  570 
OUTF  580 
OUTF  590 
OUTF  600 
OUTF  610 
OUTF  620 
OUTF  630 
OUTF  640 
OUTF  650 
OUTF  660 
OUTF  670 
OUTF  680 
OUTF  690 
OUTF  700 
OUTF  710 
OUTF  720 
OUTF  730 
OUTF  740 
OUTF  750 
OUTF  760 
OUTF  770 
OUTF  780 
OUTF  790 
OUTF  800 
OUTF  810 
OUTF  820 
OUTF  830 
OUTF  840 
OUTF  850 
OUTF  860 
OUTF  870 
OUTF  880 
OUTF  890 
OUTF  900 
OUTF  910 
OUTF  920 
OUTF  930 
OUTF  940 
OUTF  950 
OUTF  960 
OUTF  970 
OUTF  980 
OUTF  990 
OUTFIOOO 
OUTFIOIO 
OUTF1020 
OUTF1030 
OUTF1040 
OUTF1050 
OUTF1060 
OUTF1070 
OUTF1080 
OUTF1090 
OUTFllOO 
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115 


120 


125 


130 


1210 


1220 


12^0 


9999 


II 
IF 
II 


.NE.  IPUNCT(l))   GO  TO  1230 


=   II  ♦  2 
(LSTATE(II) 
=   II  ♦  1 
GO  TO  1210 
INSERT  A  BLANK  AFTER  A  COMMA. 
II  ♦  1 
C    INSERT  A  BLANK 
1230     CALL  INSERTS  (I6LANK.  II,  LCHARS,  LSTATE(1)» 
II   =   II  ♦  1 
GO  TO  1070 
CALL  PUNCHIT  (17) 
LCHARS   =   1 
USTATE  (1)   =   C 
CALL  PUNCHIT  (0) 
RETURN 


10 


20 


FORMAT   ( 

»KFOUT. 

FORMAT   ( 

END 


OUTFUIO 

0UTF1120 

OUTF1130 

OUTFU40 

OUTF1150 

OUTF1160 

OUTF1170 

1)  OUTF1180 

OUTF1190 

OUTF1200 

OUTF1210 

OUTF1220 

OUTF1230 

OUTF1240 

OUTF1250 

OUTF1260 

»0COULO  NOT  FIND  FORMAT  NUMBER  «  15,   *>  IN  THE  ARRAY  •OUTF1270 

A  DUMMY  FORMAT  STATEMENT  (Al)  WAS  INSERTED.  »   )       OUTF12e0 

lOOAl  )  OUTF1290 

OUTF1300 
OUTFUIO 
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SUBROUTINE   OUTPUT  (LIST)  OUTP   10 

C     This  ROUTINE  WRITES  THE  UCRK  FILE  RECORD  FOR  EACH  ROUT;NE  ST ATEMENTOUTP   20 

COMMON   /ALL/   ICHARS,  IDOLLAR,  lERROR*  IKNUM  (2.  50).  IPOINT,  OUTP   30 

1  1PR0G»  ISNUM»  ITYPE.  1999<i»  KFORM  (100) »  KFOUT  (3.  100).  KSNUM  OUTP   ^0 
5                 2    (2.  ^00).  LCARD  (80).  LCHARS.  LFOUT  (1000).  LSTaTE  (2000).  OUTP   50 

3    LWORDS.  NAME  (4).  NCAHDS.  NEXT.  NFORMN,  NFOUT.  NKFORM.  NOUTS.  OUTP   60 

i*         NPUSH.  NSNUMC.  NSTATN.  number  (7).  NUMIN.  NUMK.  NVALUE.  STRING  OUTP   70 

5    (2.  100)  OUTP   80 

COMMON   /DATA/   C.  END.  H.  IBLANK,  lEOF.  INTEGER  (10).  IPUNCT  OUTP   90 

10  1    (11).  ICOUNT  (2.  4).  LUIN.  LUOUT.  LUSTATE.  MFOUT.  MLCHARS.  OUTP  100 

2  MNFORM,  MNSTATE.  NCARC.  NMAX.  NUMMAX.  PROGRAM  (7).  RETURN.  OUTP  110 

3  STAR.  X  OUTP  120 
DIMENSION    LIST  (1).  LOUT  (200)  OUTP  130 

DO  1000   I   =   1.  100  OUTP  1*0 

15  1000     LOUT  (I)   =   IBLANK  OUTP  150 

00  1010   II   =   1.  200.  10  OUTP  160 

11  =   II  »  10  -  9  OUTP  170 

12  =   MINO  (II  ♦  99.  ICHARS)  OUTP  180 
NC   =   12  ♦  1  -  U  OUTP  190 

20  IF  (NC  .LE.  0)   60  TO  1020  OUTP  200 

1010     ENCODE  (NC.    10.  LOUT  (ID)    (LIST  (I).  1  =  11.  12)  OUTP  210 

1020   LWOROS   =    (ICHARS  ♦  9)  /  10  OUTP  220 

WRITE  (LUSTATE)   I  TYPE  .LWOROS.  ICHARS.  ISNUM.  (LOUTd).  1  =  1.  OUTP  230 

1    LWORDS).  NUMIN.  (  (INNUMd.  J).  1  =  1.  2).  J=l.  NUMIN)  OUTP  2*0 

25  NOUTS   =   NOUTS  ♦  1  OUTP  250 

9999   RETURN  OUTP  260 

C  OUTP  270 

10   FORMAT   (  lOOAl  )  OUTP  280 

C  OUTP  290 

30  END  OUTP  300 
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10 


15 


20 


25 


30 


3b 


^0 


45 


1000 
1010 

1020 

9999 


SUBROUTINE   OUTSTR 
THIS  ROUTINE  SETUP  THE  FINAL  DIMENSION  AND  TYPED  STATE 
COMMON   /ALL/   ICHARS.  lOOLLAR,  lERROR.  INNUM  (2.  50 
IPROG.  ISNUM,  ITYPE»  19999.  KFORM  (100).  KFOUT  (3. 
(2.  400).  LCARO  (60).  LCHARS.  LFOUT  (1000).  LSTATE 
LWOROS,  NAME  (4).  NCANDS,  NEXT,  NFORMN,  NFOUT,  NKF 
NPUSH.  NSNUMC.  NSTATN,  NUMBER  (7).  NUMIN.  NUMK.  NV 
(2,  100) 
COMMON   /DATA/   C.  END.  H.  IBLANK.  lEOF.  INTEGER  (10 
(11).  ICOUNT  (2.  4).  LUIN.  LUOUT.  LUSTATE.  MFOUT. 
MNFORM.  MNSTATE.  NCARC.  NMAX.  NUMMAX.  PROGRAM  (7). 
STAR.  X 
DIMENSION    KTYPE  (7) 
INTEGER      STRING.  TEST  (20) 
DATA     KTYPE  /  9HDIMENSI0N.  8HEXTERNAL.  7HC0MPLEX. 

7HINTEGER.  7HL0GICAL.  4HREAL   / 
NE   =   0 

DO  1020   J   =   1.  7 

THE  TYPE  IF  NONE  OCCUR 
(NUMBER(J)  .EQ.  0)   GO  TO  1020 
THE  TYPE  NAME. 
=   NUMBER  (J) 
LCHARS   =   7 

CALL  INSERTS  (KTYPE(J).  8.  LCHARS.  LSTATE(l).  10) 
LCHARS   =   19 
IPOINT   =   20 
INSERT  ONE  VARIABLE  AT  A  TIME. 
DO  1000   K   =   1,  N 
NE   =   NE  ♦  1 

DECODE  (20.    10.  STRING  (1.  NE))   TEST 
NN   =   NONR  (IBLANK.  1.  20.  TEST(l)) 
CALL  INSERTS  (STRlNGd.  NE).  IPOINT.  LCHAkS.  LST 
IPOINT   =   LCHARS  ♦  1 
IF  (K  .EQ.  N)   GO  TO  1010 

CALL  INSERTS  (IPUNCT(2).  IPOINT.  LCHARS.  LSTATE( 
IPOINT   =   LCHARS  ♦  1 
CONTINUE 
CALL  PUNCHIT  (J  ♦  6) 
NUMBER  (J)   =   0 
CONTINUE 
RETURN 


SKIP 

IF 

INSERT 

N 


10   FORMAT   (  lOOAl  ) 


END 


OUTS   10 

MENT  RECORDS 

.OUTS   20 

).  IPOINT. 

OUTS   30 

100).  KSNUM 

OUTS   40 

(2000) . 

OUTS   50 

ORM.  NOUTS. 

OUTS   60 

ALUE.  STRING 

OUTS   70 

OUTS   80 

).  IPUNCT 

OUTS   90 

MLCHARS, 

OUTS  100 

RETURN, 

OUTS  110 

OUTS  120 

OUTS  130 

OUTS  140 

6HD0UeLE. 

OUTS  150 

OUTS  160 

OUTS  170 

OUTS  180 

OUTS  190 

OUTS  200 

OUTS  210 

OUTS  220 

OUTS  230 

OUTS  240 

OUTS  250 

OUTS  260 

OUTS  270 

OUTS  280 

OUTS  290 

OUTS  300 

OUTS  310 

ATE(l),  NN) 

OUTS  320 

OUTS  330 

OUTS  340 

1).  2) 

OUTS  350 

OUTS  360 

OUTS  370 

OUTS  380 

OUTS  390 

OUTS  400 

OUTS  410 

OUTS  420 

OUTS  430 

OUTS  440 

OUTS  450 
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SUBROUTINE  PUNCHIT  (ITy 
C  This  ROUTINE  WRITES  THE  HE 
C       TAPE^.   THIS  FILE  IS  RE* 

COMMON   /ALL/   ICHAHS,  I 

1  IPROG*  ISNUM.  ITYPE.  I 

2  (2.  400)»  LCARD  (80), 

3  LWOROS*  NAME  (<»)•  NCAR 
*♦  NPUSH.  NSNUMC,  NSTATN, 
5    (2,  100) 

COMMON   /DATA/   C»  END. 

1  (11),  ICOUNT  (2,  4),  L 

2  MNFORM,  MNSTATE,  NCARC 

3  STAR,  X 

DIMENSION    LINEOUT  (72) 
INTEGER      C,  H,  STAR, 
IF  (ITY  .EU.  16)   CALL  F 
IPOINT   =   72 


) 

ORGANIZED  STATEMEN 
DY  FOR  COMPILATION 
DOLLAR,  lERROR,  IN 
S999,  KFORM  (100), 
LCHARS,  LFOUT  (100 
OS,  NEXT,  NFORMN, 
NUMBER  (7),  NUMIN 

H,  IBLANK,  lEOF,  I 
UIN,  LUOUT,  LUSTAT 
NMAX,  NUMMAX,  PR 


X 
IXDATA 


TS  ON  THE  OUTPUT  FILE 

OR  PUNCHING. 
NUM  (2,  50),  IPOINT, 

KFOUT  (3,  100),  KSNUM 
0),  ESTATE  (2000), 
NFOUT,  NKFORM,  NOUTS, 
NUMK,  NVALUE,  STRING 

NTE6ER  (10),  IPUNCT 
E,  MFOUT,  MLCHARS, 
OGHAM  (7),  RETURN, 


NNN   =   7 
DO  1000 


I   = 


1000 


LINEOUT  (I) 


1,  72 
ESTATE 


(I) 


NCARDS   =   NCARDS  ♦  1 
IF  (NCARDS  .LT.  1000)   GC 
ICOUNT  (1,  2)   =   ICOUNT 
NAME  (A)   =   IPUNCT  (5) 
NCARDS   =   1 
1010   CONTINUE 

:     ONE  OR  THE  FIRST  CARD  OUTPL 
IF  (LCHARS  .LE.  72)   GO 
IF  (ITY  .EQ.  16)   GO  TO 
NNN   =   10 

IF  (LSTATE(73)  .EQ.  IBLANK  .OR.  LINE0UT(72)  .EQ.  IBLANK)   GO  TO 
1080 


:-0  TO  1010 
(1,  2)  ♦  99 


'UT. 
TO  1080 
1020 


1 

;  FIND  THE  LAST  BLANK  FOR  Tih 
N  =  ISCANR  (IBLANK,  62 
IF  (N  .GE.  62  .AND.  N  .L 
IF  (ITY  .NE.  17)  GO  TO 
:  WITH  A  FORMAT  OR  A  DATA  ST 
1020  N2  =  ISCANR  (IPUNCT (2) 
Nl  =  ISCANR  (IPUNCT (1) 
ISCANR  (IPUNCT (4) 
MAXO  (Nl,  N2,  N4) 
.EQ.  73)   GO  TO  10 


(N 


1030 

io4o 


1050 


N4 

N 

IF 

NNN   =   7 

IF  (N  .LT.  62)   GO  TO  10 

NNN   =   10 

DO  1040   I   =   N,  72 
LINEOUT  (I)   =   IBLANK 

IPOINT   =   N 

GO  TO  1080 

IF  (ITY  .EQ.  16)   GO  TO 

IF  (LINEOUT(72)  .EQ.  IPU 
HERE  TO  INSERT  AN  »  INTO  A 

N5   =   ISCANR  (IPUNCT(5) 

Nil   =   ISCANR  (IPUNCTd 

J   =   5 


E  BREAK  LOCATION. 
,  72,  LINEOUT(l)) 
E.  72)   GO  TO  1030 
1080 

ATEMENT  BREAK  ONLY 
,  61,  72,  LINEOUT( 
»  61 »  72,  LINEOUT ( 
,  61,  72,  LINEOUT ( 

70 

50 


AFTER  A  COMMA,  /,  OR  ) 
D)  ♦  1 
1))  ♦  1 
1)  )  ♦  1 


1080 

NCT(5))   GO  TO  107 

FORMAT  STATEMENT. 

,  16,  71,  LINEOUT( 

1),  16,  71,  LINEOU 


1)) 
T(l)  ) 


PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 
PUNC 


10 
20 
30 
40 
50 
60 
70 
80 
90 
100 
110 
120 
130 
140 
150 
160 
170 
180 
190 
200 
210 
220 
230 
240 
250 
260 
270 
280 
290 
300 
310 
320 
330 
340 
350 
360 
370 
380 
390 
400 
410 
420 
430 
440 
450 
460 
470 
480 
490 
500 
510 
520 
530 
540 
550 
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60 


65 


70 


75 


80 


85 


90 


95 


100 


105 


110 


IF  (Nil  .LT.  N5)   GO  TO  1060 
N5   =   Nil 
J   =   11 
1060   CONTINUE 

NH   =   ISCANR  (H.  16»  71 
IF  (Nh  .GT.  N5  .OR.  N5  . 
LINEOUT  (72)   =   IPUNCT 
IPOINT   =   IPOINT  -  1 
LSTATE  (IPOINT) 


.  LINEOUT(l)) 

LT.  16)   60  TO  lOeO 

(J) 


IPUNCT  (J) 


IPOINT   =   IPOINT  -  1 

10  70   NNN   =   10 

1080   WHITE  (LUOUT.    10)   LIN 
IF  (LCHARS  .LE.  72)   GO 
C     MULTIPLE  CARD  OUTPUT. 

IC   =   1 
C     INDENT  THE  REMAINING  DATA 
C       NN      THE  STARTING  LOCA 

NN   =   10  ♦  2  »  NPUSH 
C     FORMAT  OR  DATA  STATEMENT, 
IF   (ITY  .EQ.  16  .OR.  IT 

1090     00  1100   I   =   1»  72 

1100     LINEOUT  (I)   =   IBLANK 

1110   IF  (LSTATE(IP0INT+1)  .NE 
IPOINT   =   IPOINT  ♦  I 
GO  TO  1110 

1120     DO  1130   I   =   NN.  72 
IPOINT   =   IPOINT  ♦  1 

1130     LINEOUT  (I)   =   LSTATE 
IC   =   MINO  (IC  ♦  1.  10) 
LINEOUT  (6)   =   INTEGER 
NCAROS   =   NCARDS  ♦  1 
IF  (NCAROS  .LT.  1000)   G 
ICOUNT  (1»  2)   =   ICOUNT 
NAME  (4)   =   IPUNCT  (5) 
NCARDS   =   1 

U'tO   CONTINUE 

IF  (LCHARS  .LE.  IPOINT) 
IF  (ITY  .EU.  16)   GO  TO 
IF  (LSTATE(IP0INT+1)  .EG 
GO  TO  1210 
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PUNC  560 
PUNC  570 
PUNC  580 
PUNC  590 
PUNC  600 
PUNC  610 
PUNC  620 
PUNC  630 
PUNC  640 
PUNC  650 
PUNC  660 
PUNC  670 
PUNC  680 
PUNC  690 
PUNC  700 
PUNC  710 
PUNC  720 
PUNC  730 
PUNC  740 
PUNC  750 
PUNC  760 
PUNC  770 
PUNC  780 
PUNC  790 
PUNC  800 
PUNC  810 
PUNC  820 


EOUT.  NAMEt  NCAROS 
TO  1220 


STRING. 

TION  FOR  THE  CONTINUATION  CARDS. 

CAN  NOT  BE  INDENTED. 
Y  .EQ.  17)   NN   =   NNN 


.  IBLANK)   GO  TO  1120 

( IPOINT) 

(IC) 

0  TO  1140 
(1,  2)  ♦  99 


GO  TO  1210 
1150 
.  IBLANK  .OK.  LINE0UT(72)  .EQ.  IBLANK) 


1150 


1 

FIND  THE  LAST  BLANK  FOR  THE  BREAK  LOCATION. 

»  72,  LINEOUT (1) ) 
E.  72)   GO  TO  1160 
1210 

ATEMENT  BREAK  ONLY  AFTER  A  COMMA,  /,  OR 
,  61,  72,  LINEOUT(l))  ♦  1 
,  61,  72,  LINEOUT(l))  ♦  1 
,  61,  72,  LINEOUT (1) )  ♦  1 


N 
IF 
IF 
WITH 
N2 
Nl 
N4 
N 
IF 
NN 


ISCANR  (IBLANK,  62 
(N  .GE.  62  .AND.  N  .L 
(ITY  .NE.  17)   GO  TO 
A  FORMAT  OR  A  DATA  ST 
=   ISCANR  (IPUNCT(2) 
=   ISCANR  ( IPUNCT  (1) 
=   ISCANR  (IPUNCT(4) 
=   MAXO  (Nl,  N2,  N4) 
(N  .EQ.  73) 


1160 
1170 


IF  (N  .LT.  62) 

NN   =   10 
DO  1170   I 
LINEOUT  (I) 


GO  TO  1200 

GO  TO  1180 

N,  72 
IBLANK 


PUNC  830 
PUNC  840 
PUNC  850 
PUNC  860 
PUNC  870 
PUNC  880 
PUNC  890 
PUNC  900 
PUNC  910 
PUNC  920 
PUNC  930 
PUNC  940 
PUNC  950 
PUNC  960 
PUNC  970 
PUNC  980 
PUNC  990 
)PUNC1000 
PUNCIOIO 
PUNC1020 
PUNC1030 
PUNCI040 
PUNC1050 
PUNC1060 
PUNC1070 
PUNC1080 
PUNC1090 
PUNCllOO 
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lis 


120 


125 


130 


135 


UO 


IPOINT   =   N  ♦  IPOINT  -  72 

GO  TO  1210 
1180   IF  (ITY  .eu.  16)   60  TO  1210 

IF  (LINE0UT(72)  .ECl.  IPbNCT(5))   GO  TO  1200 
;     HEHE  TO  INSERT  AN  «  INTO  A  FORMAT  STATEMENT. 

N5   =   ISCANK  (IPUNCT(5).  NN,  71.  LlNEOUT(l)) 

Nil   =   ISCANR  (IPUNCTdl).  NN.  71.  LINEOLT(l)) 

J   =   5 

IF  (NU  .LT.  N5)   GO  TO  IISO 

J   =   11 

N5   =   Nil 
1190   CONTINUE 

NH   =   ISCANR  (H.  NN.  71.  LINEOUT(l)) 

IF  (NH  .GT.  N5  .OR.  N5  .LT.  NN)   GO  TO  1210 

LINEOUT  (72)   =   IPUNCT  (J) 


1200 
1210 


1220 
12J0 

9999 


IPOINT 
LSTATE 
IPOINT 
NN   = 


=  IPOINT  - 
(IPOINT) 

=  IPOINT  - 
10 


IPUNCT 
1 


(J) 


WRITE  (LUOUT. 
IF  (IPOINT  .LT, 

DO  1230   I   = 
LSTATE  (1)   = 

LCHARS   =   0 
RETURN 


10)   LINEOUT,  NAME.  NCARDS 
LChARS)   60  TO  1090 

1.  LChARS 
IbLANK 


10   FORMAT   (  76A1.  13.   *»0»   ) 

ENU 


PUNCIUO 
PUNC1120 
PUNC1130 
PUNCll'fO 
PUNC1150 
PUNC1160 
PUNC1170 
PUNC1180 
PUNC1190 
PUNC1200 
PUNC1210 
PUNC1220 
PUNC1230 
PUNC12^0 
PUNC1250 
PUNC1260 
PUNC1270 
PUNC1280 
PUNC1290 
PUNC1300 
PUNC1310 
PUNC1320 
PUNC1330 
PUNCU'iO 
PUNC1350 
PUNC1360 
PUNC1370 
PUNC1380 
PUNC1390 
PUNCl^OO 
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SUBROUTINE   READS 
C     THIS  ROUTINE  READS  THE  INPUT  FILE  AND  GENERATES  THE  WORK  FILE   AND 
C       STRINGS  FOR  LATER  PROCESSING. 

COMMON   /ALL/   ICHARS.  IDOLLAR*  lERROR.  INNUM  (2»  50).  IPOINT. 

1  IPROG»  ISNUM»  ITYPE,  19999.  KFORM  (100).  KFOUT  <3.  100).  KSNUM 

2  (2.  400).  LCARD  (80).  LCHARS.  LFOUT  (1000).  LSTATE  (2000). 

3  LWORDS.  NAME  (4).  NCARDS.  NEXT.  NFOHMN.  NFOUT.  NKFORM.  NOUTS. 

4  NPUSH.  NSNUMC.  NSTATN.  NUMBER  (7).  NUMIN.  NUMK,  NVALUE.  STRING 

5  (2.  100) 

COMMON   /DATA/   C.  END.  H.  IBLANK.  lEOF.  INTEGER  (10).  IPUNCT 

1  (11).  ICOUNT  (2.  4).  LUIN.  LUOUT.  LUSTaTE.  MFOUT.  MLChARS. 

2  MNFORM.  MNSTATE.  NCARC.  NMAX.  NUMMAX,  program  (7).  RETURN. 


STAR.  X 
DIMENSION 
INTEGER 
LOGICAL 

DATA     NAMES  /  IHN.  IhA.  IHM. 
DATA     GOTO  /  5HG0  TO   / 

=   1 

0) 


NAMES  (4.2) 

C.  END.  GOTO.  PROGRAM.  STAR.  STRING.  TRANSF 

CHECK,  KLIST.  KO 

IHE.  IHD.  IHA.  INT.  IHA   / 


ICOUNT  (1.  1) 

IF  (NCARD  .NE.  0)   GO  TO  1020 

ICOUNT  (1.  1)   =   0 
1000   READ  (LUIN.    10)   LCARD 

ICOUNT  (1.  1)   =   ICOUM  (1.  1)  ♦  1 

IF  (EOF(LUIN))    I860.  1010 
1010   NCARD   =   1 
:     CHECK  FOR  A  COMMENT  CARD.  IF  SO  OUTPUT. 
1020   IF  (lEOF  .EQ.  1)   GO  TO  9999 

IF  (LCARD(l)  .EQ.  C  .OR.  LCARD(l)  .EQ.  STAR)   GO  TO  1030 
;     CHECK  FOR  AN  ALL  BLANK  CARD.  IF  SO  OUTPUT  C  CARD. 

IF  (N0NL(IBLANK.1.72.LCARD(1))  .LE.  72)   GO  TO  1050 

ICHARS   =   1 

GO  TO  1040 
1030   ICHARS   =   NONR  (IBLANK.  2.  72.  LCARD(l)) 
1040   ITYPE   =   0 

LCARD  (1)   =   C 

CALL  OUTPUT  (LCAHD(l) ) 

NCARD   =   0 

GO  TO  1000 
;     CHECK  FOR  A  STATEMENT  NUMBER  IN  THE  FIRST  5  COLUMNS. 
1050   N   =   NONL  (IBLANK.  1.  5.  LCARD(l)) 

IF  (N  .GT.  5)   GO  TO  1060 
:     YES.   NOW  DETERMINE  ITS  VALUE 

ISTOP   =   5 

NVALUE   =   NUMBS  (N.  ISTOP.  LCARD(l)) 

IF  (NVALUE  .GT.  0)   GO  TO  1060 

PRINT    20.  LCARD 

60  TO  1030 
:     TRANSFER  THIS  RECORD  TO  LSTATE. 
1060   ITRANS   =   TRANSF  (7,  72) 
1070   IF  (ITRANS  .GT.  0)   GO  TO  1100 
:     READ  THE  NEXT  INPUT  RECORD. 

READ  (LUIN.    10)   LCARC 

ICOUNT  (1.  1)   =   ICOUNT  (1.  1)  ♦  1 

IF  (EOF(LUIN))    1090,  1080 
lOaO   NCARD   =   1  ♦  NCARD 


READ 

10 

READ 

20 

READ 

30 

READ 

40 

READ 

50 

READ 

60 

READ 

70 

READ 

80 

READ 

90 

READ 

100 

READ 

110 

READ 

120 
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C     CHECK  I?    A  CONTINUATION  RECOHD.  READ  560 

IF  (LCAND(6)  .tU.  INTEGER*!)  .OR.  LCAR0(6)  .EO.  IBLANK  .OR.  READ  570 

1    LCARD(l)  .EQ.  C  .OR.  LCARD (  1)  .EU.STAR)   GO  TO  1100  READ  580 

C     YES.  THEN  SET  UP  FOR  THE  TRANSFER  TO  LSTATE.  READ  590 

60                   N   =   NONL  (IBLANK.  1.  5.  LCAROd))  HEAD  600 

IF  (N  .GT.  5)   GO  TO  1060  READ  610 

GO  TO  1100  READ  620 

C     THE  ENTIRE  ARRAY  HAS  BEEN  CONSTRUCTED.  NOW  IDENTIFY  Tl-E  TYPE  AND    READ  630 

C       INSERT  THE  PROPER  SPACING.  READ  6^0 

6b             1090   lEOF   =   1  READ  650 

ICOUNT  (1.  1)   =   ICOUM  (1.  1)  -  1  READ  660 

1100   IF  (IPROG  .NE.  0)   GO  TC  1200  READ  670 

CALL  BLANKS  READ  680 

C     DO  PROGRAM  STATEMENTS  HYPE  =  1.  2.  3.  4.                             READ  690 

70                   IPOINT   =   1  READ  700 

J   =   ICENT  (1)  READ  710 

IF  (J  ,NE.  45)   GO  TO  1120  READ  720 

C     NO  ROUTINE  TYPE  CARD  FOUND.  THIS  IS  AN  ERROR.                         READ  730 

PRINT    30  READ  740 

75                  IPROG   =   100  READ  750 

DO  1110   I   =   1.  4  READ  760 

1110     NAME  (I)   =   NAMES  (I.  1)  READ  770 

GO  TO  1200  HEAD  780 

C     A  ROUTINE  TYPE  MATCH  WAS  FOUND.  READ  790 

80             1120   ITYPE   =   J  READ  800 

IPROG   =   J  READ  810 

IF  (J  .NE.  4)   GO  TO  1140  READ  820 

C     HERE  FOR  BLOCK  DATA.  READ  830 

CALL  INSERT  (IBLANK,  IPGINT  -  4.  LCHARS.  LSTATE(l).  1)  READ  840 

85                  IPUINT   =   IPOINT  ♦  1  READ  850 

C     IS  THE  BLOCK  DATA  NAMED.  READ  860 

IF  (IPOINT  .LE.  ICHARS)   GO  TO  1140  READ  870 

C     NO  .USE  *-DATA«.  READ  880 

DO  1130   I   =   1.  4  READ  890 

90             1130     NAME  (I)   =   NAMES  (I,  2)  READ  900 

GO  TO  1690  READ  910 

C     FINALLY   SETUP  THE  NAME.  READ  920 

1140   CALL  INSERT  (IBLANK.  IPOINT,  LCHARS.  LSTATE(l),  2)                 READ  930 

IPOINT   =   IPOINT  ♦  2  READ  940 

95            C     OBTAIN  THE  ROUTINE  NAME  FOR  LATER  USE  IN  THE  OUTPUT  CARD  COL  73-76. READ  950 

IP   =   IPOINT  READ  960 

DO  1150   I   =   1.  4  READ  970 

IF  (LSTaTE(IP)  .EU.  IPUNCT(3))   GO  TO  1160                        READ  980 

NAME  (I)   =   LSTATE  HP)  READ  990 

100             1150     IP   =   IP  ♦  1  READIOOO 

lltiO   CONTINUE  READIOIO 

IF  (IPROG  .NE.  1)   GO  TO  1680  REA01020 

DO  1170   I   =   1.  4  READ1030 

1170     ICOUNf  (2.  I)   =   0  READ1040 

105                     00  1180   I   =   1.  7  READ1050 

1180     PROGRAM  (I)   =   IBLANK  READ1060 

IP   =   IPOINT  READ1070 

DO  1190   1=1.7  READ1080 

IF  (LSTATE(IP)  .EU.  IPUNCT(3))   GO  TO  1680                        READ1090 

110                     PROGRAM  (I)   =   LSTATE  (IP)  READllOO 
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ll'iO     IP   =   IP  ♦  1  READlllO 

GO  TO  1680  REAO1120 

C    START  PROCESSING  THE  ROUTINE  STATEMENTS.  READIUO 

1200   IPOINT   =   1  REAOllAO 

115                  J   =   IDENT  (2)  REA01150 

lERROR   =   J  REA01160 

ITYPE   =   J  READ1170 

IF  (J  .LE.  't  .OR.  J  .GT.  45)   GO  TO  1800  REAUlieO 

CALL  BLANKS  READ1190 

120  GO  TO   (  12^0.  1220.  1260.  1260.  1220.  1220.  1220.  1220.  1220.    READ1200 

1  1250.  1270.  1210.  1290.  1310.  1320.  1230.  1380.  1220.  1^60.     READ1210 

2  1700.  1<.70.  1230.  1230.  1470.  1230.  1490.  1500.  1470.  1470.     READ1220 

3  1220.  1220.  1220.  1570.  1220.  1220.  1580.  1220.  1220.  1620.     READ1230 

4  1790,  16t0)   J  -  4  READ1240 
125            C     MAKE  A  SPECIAL  CHECK  FOR  CATA  STATEMENTS.  J  =  16.  READ1250 

C       DATA  (TEXT (I) ,1=1.9)  /  LIST    IS  OK.  MUST  CHECK  FOR  THE  RELATIVE  READ1260 

C       POSITIONS  OF  THE  MATCHING  (  )♦  14.  AND  THE  =.  18.  READ1270 

1210   IF  (LSTATE(IPOINT)  .N£.  IPUNCT(3))   GO  TO  1230  READ1280 

14   =   MATCH  (IPOINT.  KHARS.  LSTATE(l))  REA01290 

130                  18   =   ISCANL  (IPUNCT(8).  IPOINT  ♦  1.  ICHARS,  LSTATE(l))  READ1300 

IF  (18  .LT.  14)   GO  TO  1280  REAO1310 

GO  TO  1630  READ1320 

C     CHECK  FOR  (  OR  =  FOLLOWING  THE  TYPE  WORD  JUST  IDENTIFIED.  READ1330 

1220   IF  (LSTATE( IPOINT)  .E(J.  IPUNCT(3))   GO  TO  1630  READI340 

135            1230   IF  (LSTATE(IPOINT)  .EtI.  IPUNCT(8))   GO  TO  1630  REA01350 

C     NOW  WORK  THE  STATEMENTS.  READ1360 

GO  TO   (  1240.  1620.  1260.  1260.  1260,  1260.  1260.  1260.  1260.    READ1370 

1  1250.  1270.  1280.  1290.  1310.  1320.  1360.  1380.  1450.  1460.     REA013eo 

2  1700.  1470.  1480.  1480.  1470.  1480,  1490.  1500.  1470,  1470,     READ1390 
140                3    1520,  1520,  1530,  1570,  1580.  1580.  1580.  1590.  1580.  1620.     REA01400 

4    1790.  1640)   J  -  4  READ1410 

C  READ1420 

1240   CALL  INSERT  (IBLANK.  IPOINT  -  1.  LCHARS.  LSTATE(I).  2)  READ1430 

IPOINT   =   1  ♦  ISCANL  (IPUNCT(l).  IPOINT  ♦  3.  ICHARS.  LSTATE(l))  READ1440 

145                  GO  TO  1620  READ1450 

C     SET  PRECISION  TO  DOUBLE.  READ1460 

1250   J   =   10  READ1470 

C     STORE  THE  TYPE  STATEMENTS  IN  THE  ARRAY  STRING.  READ1480 

1260   CALL  STORE  (J  -  6)  READ1490 

150                  GO  TO  1730  READ1500 

C     EQUIVALANCE  STATEMENTS  INSERT  A  BLANK  (15).  READ1510 

1270   CALL  INSERT  (IBLANK,  IPCINT  -  1,  LCHARS,  LSTATE(l),  1)  READ1520 

GO  TO  1680  READ1530 

C     DO  DATA    STATEMENTS  J  =  16.  READ1540 

155            1280   CALL  INSERT  (IBLANK,  IPOINT.  LCHARS.  LSTATE(l).  4)  READ1550 

IPOINT   =   IPOINT  ♦  4  READ1560 

GO  TO  1680  REA01570 

C     DO  FORMAT  STATEMENTS   J   =   17.  REA01580 

1290   ICHARS   =   ICHARS  -  IPOINT  READ1590 

160                  IF  (  .NOT.  KO(NVALUE))   GO  TO  1730  READ1600 

IN   =   KFOUT  (2.  NFOUT)  READ1610 

DO  1300   II   =   IN.  1000.  10  REAO1620 

12   =   MINO  (IPOINT  ♦  99.  LCHARS  -  1)  READ1630 

IC   =   12  ♦  1  -  IPOINT  READ1640 

165                    IF  (IC  .LE.  0)   GO  TO  1730  READ1650 
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ENCODE  (IC.    10.  LFOUT  (ID)    (LSTaTE  (I».  .1  =  IP0INT,  12)  REAU1660 

1300     IHOINT   =•   IPOINT  ♦  100                  .  KEAD1670 

GO  TO  1730  HEA016bO 

C     J   =   18   STATEMENT  TYPE  CO  999   I   =v9.  99  -  READ1690 

170             1310   N   =   NUMBS  (IPOINT,  LCt-ARS,  LSTATEd))  HEA01700 

IF  (N  .LE.  0)   &0  TO  1630  READ1710 

IF  (  .NOT.  kLIST(IPOINT.N) )   GO  TO  1640   .  REAO1720 

CALL  INSERT  (IBLANK,  IPOINT*  LCHAHS*  LSTATE(l)*  2)  READ1730 

GO  TO  1640  READ1740 

175           C     J   =   19   STATEMENT  TYPE  GO  TO   -(9999.9999)  V       •  READ1750 

1320   CALL  INSERT  (IBLANK,  IPOINT  :-  1.  LCHARS,  LSTATE(l).  2)             HEAD1760 

CALL  INSERT  (IBLANK,  IPOINT  -  3,  LCHARS,  LSTATEd),  1)             REAU1770 

IPOINT   =   IPOINT  ♦  3  READ1780 

N   =   NUMBS  (IPOINT,  LOBARS,  LSTATE(l))  READ1790 

180            C     THERE  MUST  BE  STATEMENT  NLMBEK  IN  THE  FIRST  POSITION.  READ1800 

IF  (N  .LE.  0)   GO  TO  1630                    .  READ1810 

60  TO  1340                                ,         I  REA01820 

1330   N   =   NUMBS  (IPOINT,  LCt-ARS,  LSTaTE(I))  REAC)1830 

IF  (N  .LE.  0)   GO  TO  1350  REAU1840 

185            1340   IF  (  .NOT.  KL  1ST ( IPOINT  ,N) >   GO  TO  1620  REAO1850 

IPOINT   =   IPOINT  ♦  1  READ1860 

IF  (LSTATEdPOlNTr-n  .EC.  IPUNCT14))   60  TO  1350  REAUie70 

60  TO  1330  READleeO 

..1350-   IF   (LSTATE(IPOINT)  .EO.  IPUNCT (2) )   IPOINT   =.  IPOINT.*  1  READ1890 

190                  GO  TO  1620  READ1900 

C     J   =   20   STATEMENT  TYPE  CO  TO   9999  READ1910 

1360   CALL  INSERT  (IBLANK,  IPOINT  -  2,  LCHARS,  LSTATEd),  1)             READ1920 

IPOINT   =   IPOINT  ♦  1  READ1930 

N   =   NUMBS  (IPOINT,  LCHARS,  LSTATEd))  READ1940 

195                  IF  (N  .GT.  0)   GO  TO  1370  •  READ1950 

C     DO  THE  ASSIGNED  GO  TO  X  (9,99,999,9999)  READ1960 

CALL  INSERT  (IBLANK,  IPOINT*  LCHARS,  LSTATEd),  2)  READ1970 

IPOINT   =   IPOINT  ♦  2  REA01980 

IPOINT   =   ISCANL  dPUNCT(3).  IPOINT.  LCHARS,  LSTATEd))  READ1990 

200                   CALL  INSERT  (IBLANK,  IPOINT.  LCHARS,  LSTATEd).  1)  REAO2000 

IPOINT   =   IPOINT  ♦  2  .             READ2010 

■  60  TO  1330  READ2020 

1370   IF  (  .NOT.  KLlSTdPOINT.N)  )   GO  TO  1680  REA02030 

ISTOP   =   ICHARS   =   INNUM  (1.  1)  -  1  READ2040 

205                  GO  TO  1690                                     •  •             READ2050 

,G     J   =   21   STATEMENT  TYPE  IF  (V)  »»«  READ2060 

1380   CALL  INSERT  (IBLANK,  IPOINT  -  1,  LCHARS,  LSTATEd),  1)             REA02070 

IPOINT   =   1  ♦  MATCH  (IPOINT.  LCHARS,  LSTATEd))  READ2080 

CALL  INSERT  (IBLANK,  IPOINT,  LCHARS,  LSTATEd),  2)  REA02090 

210                  IPOINT   =   IPOINT  ♦  2  READ2100 

N   =   NUMBS  (IPOINT,  LCHARS,  LSTATEd))  READ2110 

IF  (N  .LE.  0)   60  TO  I4l0  READ2120 

60  TO  1400  READ2130 

^    1390   IPOINT   =   IPOINT  ♦  1  READ2140 

215                ,   N   =   NUMBS  (IPOINT,  LCHARS,  LSTATEd))  READ2150 

IF  (N  .LE.  0)   60  TO  16S0  READ2160 

1400   IF  (KLlSTdPOINT.N))   GO  TO  1390  REA02170 

60  TO  1680  READ2180 

1410   JJ   =   IDENT  (2)                -       .  READ2190 

220                  IF  (JJ  .LE.  18  .OR.  JJ  .6T.  45)   60  TO  1800  READ2200 
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225 


230 
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250 
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GO  TU   (  1320>  l<t<tO*  13iJ0«  1430*  1460*  1700«  1<»70»  1440*  1440«    REA02210 

1  l<i70<  It'fOf  1430t  1500«  1470*  U7Ut  l<i30t  U30t  1430*  l<i20t     REAU2220 

2  1<»30»  1<*30*  1560«  l<t30«  1<»30«  1620«  1790«  1640)  JJ  -  18        REAO2230 
U20   IF  (LSTATEdPUINT)  .EQ.  IPONCT(S))   GO  TO  1760  KEAD2240 

C     CHECK  FOR  At  («  OH  A«  =«  FOLLOWING  THE  IDENTIFIES  NAME.  REA022SO 

1430   IF  (LSfATEdPOINT)  .EO.  tPUNCT(3))   GO  TO  1640  REA02260 

1440   IF  (LSTATE(IPOINT)  .Eti.  IPUNCT(B))   GO  TO  1640  KEALI2270 

C  NEA02280 

GO  TO   (  1320t  1360t  1380*  1450«  1460*  1700t  1470*  1480*  1480*    REA02290 

1  1470*  1480*  1490*  1500*  1470*  1470*  1520*  1520*  1550*  1570*     REA02300 

2  1580*  1580*  1580*  1590*  1580*  1620*  1790*  1640)  JJ  -  18        REA02310 
C  REA02320 

1450   CALL  INSERT  (IBLANK*  IPOINT*  LCHARS*  LSTATE<1)«  1)  READ2330 

IPOINT   =   IPOINT  *  2  HEA02340 

GO  TO  1680  REA02350 

C     J   =   23   STATEMENT  TYPE  ASSIGN  9999  TO  V  READ2360 

1460   N   =   NUMBS  (IPOINT*  LCHARS*  LSTATEd))  READ2370 

IF  (N  .LE*  0)   GO  TO  1630  REA023eO 

IF  (  .NOT.  KLlSTdPOINT.Nn   GO  TO  1680  REA02390 

CALL  INSERT  (IBLANK*  IPOINT*  LCHARS*  LSTATEd)*  1)  REA02400 

IPOINT   =   IPOINT  *  1  READ2410 

IF  (  .NOT.  CHECK(2HT0*2*IP0INT*ICHARS*LSTATE(1>«IP0INT))   GO  TO   REA02420 

1    1680  REA02430 

CALL  INSERT  (IBLANK*  IPOINT*  LCHARS*  LSTATEd)*  2)  REA02440 

GO  TO  1690  REA024SO 

C     J   =   25   STATEMENT  TYPE  READ  (XX*YY)  LIST  REA02460 

C     J   s   28   STATEMENT  TYPE  URITE  (XXtYY)  LIST  REA02470 

C     J   =   32   STATEMENT  TYPE  DECODE  (XX*YV»W)  LIST  HEA02480 

C     J   =   33   STATEMENT  TYPE  ENCODE  (XX.YY*V)  LIST  REA02490 

1470   CALL  INSERT  (IBLANK*  IPOINT  -  1*  LCHARS*  LSTATEd)*  1)  REAO2500 

IPUINT   =   IPOINT  «  1  REA02510 

1   =   1*  MATCH  (IPOINT.  LCHAHS*  LSTATEd))  REA02520 

CALL  INSERT  (IBLANK.  I*  LCHARS*  LSTATEd)*  2)  REA02S30 

IPOINT   =   ISCANL  dPUNCT(2)*  IPOINT*  lOHARS*  LSTATEd))  *    1  REAO2540 

C     J   s   26   STATEMENT  TYPE  READ  XX*  LIST  READ2550 

C     J   s   27   STATEMENT  TYPE  PRINT  XX*  LIST  REA02560 

C     J   i   29   STATEMENT  TYPE  PUNCH  XX*  LIST  REA02570 

N   s   NUMBS  (IPOINT*  LCHARS*  LSTATEd))  REA025eO 

IF  (N  .LE.  0>   GO  TO  1680  REA02590 

IF  (  .NOT.  KLISTdPOINT.N))   GO  TO  1680  READ2600 

CALL  KF  (N>  READ2610 

GO  TO  1680  REA02620 

=   30   STATEMENT  TYPE  tUFFER  IN   (XX*YY*V)  LIST  READ2630 

CALL  INSERT  (IBLANK*  IPOINT  -  3*  LCHARS*  LSTATEd)*  1)  READ2640 

GO  TO  1510  READ2650 

=   31   STATEMENT  TYPE  tUFFER  OUT  (XX*YY*V)  LIST  REA02660 

CALL  INSERT  (IbLANK*  IPOINT  -  4*  LCHAHS*  LSTATEd)*  1)  REAU2670 

CALL  INSERT  (IBLANK*  IPOINT*  LCHARS*  LSTATEd)*  1)  REA02680 

IPOINT   =   IPOINT  ♦  1  REA02690 

IPOINT   =   1  ♦  MATCH  (IPOINT*  LCHARS*  LSTATEd))  READ2700 

GO  TO  1620  READ2710 

C     J   =   34   STATEMENT  TYPE  STOP  REA02720 

C     J   =   35   STATEMENT  TYPE  ENTRY  ROUTINE  READ2730 

1520   CALL  INSERT  (IBLANK*  IPOINT*  LCHARS*  LSTATEd).  1)  REA02740 

GO  TO  1690  REA02750 
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C     J   =   J6   CHANGE  A  (HtTUH^)  TO  A  <  GO  TO  99S9). 
c      UNLESS  This  is  a  NUMBEHED  i^ETUHN. 
1530   CONTINUE 

IF  (ICHAr^S  .GT.  6)   GO  TO  l6lO 

IF  (lOOLLAH  .GT.  0)   GO  TO  1760 

IHOINT   =   1 
IS'.O   LCHARS   =   IPOINT  -  1 
C     CHECK  IF  THE  NEXT  HECO«0  IS  AN  END  STATEMENT. 

IHl   =   7 

IP2   =   72 

IF  (  .NOT.  CHECK(END»3.IPltIPiJ.LCAHD(l)»IP3) )   GO  TO  1560 

IF  (N0NL(IbLANK.IP3f IP2tLCAHD(i) )  .GT.  IH2)   GO  TO  1770 

GO  TO  1560 
C     ENTEH  HERE  FOK  AN  IF  STATEMENT 
1550   IF  (KHARS  .GE.  IPOINT)   CO  TO  1620 

IF  (lOOLLAR  .GT.  0)   GO  TO  1620 

IPOINT   =   IPOINT  -  6 

GO  TO  15'.0 
1560   CALL  INSERTN  (9999»  IPOlNTt  LCHARSt  LSTATE(l).  4) 

CALL  INSERT  (GOTO,  IPOINT,  LCHARS,  LSTATE(l),  5) 

19999   =   1 

ICHARS   =   LCHARS 

GO  TO  1690 
C     J  =  37  USE  (LFN> 
1570   IPOINT   =   1 

GO  TO  1680 
C     J   =   33,  39,  40,  42   ENOFILE,  REWIND,  BACKSPACE,  OH  PAUSE. 
1580   CALL  INSERT  (IBLANK,  IPtJiNT,  LCHARS,  LSTaTE(I),  1) 

GO  TO  1690 
C     J   =   41   SURPRESS  THE  WOt^O  TYPE. 
1590     00  1600   I   =   1,  4 
1600     CALL  SHIFTL  (IBLANK,  1,  LCHARS,  LSTATE(l)) 

GO  TO  1200 
C     CH  AN6E  A  NUMBERED  RETURN  To  J  =  44. 
1610   J   =   44 

lERROR   =   J 

ITYPE   =   J 
C     J   =   43   NAMELIST. 
1620   CALL  INSERT  (IBLANK,  IPOINT,  LCHARS,  LSTATE(l),  2) 

IPOINT   =   IPOINT  ♦  2 

GO  TO  1680 
C     J   =   45   REPLACEMENT  STATEMENT  TYPE  X   =   V 
1630   J   =   45 

ITYPE   =   J 
1640   IP   -   1 
C     CHECK  FOR  THE  EQUAL,  =,  SIGN, 

IPOINT   =   ISCANL  (IPUNCT(8)»  IP,  ICHARS,  LSTftTEd)) 

IF  (IPOINT  .LT.  ICHARS)   GO  TO  1660 

PRINT    40,  (LSTATE(I),  1=1,  LCHARS) 

GO  TO  1670 
1650   IPOINT   =   ISCANL  (IPUNCT(8),  IP,  ICHARS,  LSTaTE(I)) 

IF  (IPOINT  .GE.  ICHARS)   GO  TO  1670 
1660   CALL  INSERT  (IBLANK,  IPOINT  *    1,  LCHARS,  LSTATE(l),  2) 

CALL  INSERT  (IBLANK,  IPOINT,  LCHARS,  LSTATE(l),  2) 

IP   =   IPOINT  ♦  5 
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READ3200 
REA03210 
READ3220 
READ3230 
REA03240 
REA03250 
REA03260 
REA03270 
REA032eO 
REA03290 
REA03300 
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SUBROUTINE   READS 


GO  TO  1650 
1670   IPOINT   =   2 

1680   CALL  SPACOUT 


335 


340 


345 


350 


355 


360 


365 


370 


375 


380 


385 


ALUE  .LE.  0)   GO  TO  1720 

=   NSTATN  ♦  1 
TATN  .GT.  MNSTATE)   GO  TO  1-810 
(It  NSTATN)   =   NVALUE 
.EQ.  36)   GO  TO  1710 

=   NSNUMC  +  10     '    ■  ;  '  . 

=   NbMUMC 
(2.  NSTATN)   =   NSNUMC 
1720 

=   0 
(2»  NSTATN)   =   9S99 

=   1 
UTPUT  (LSTATE(l)) 
ESETX  - 

=   1  ' 

OLLAK  .LE.  0)   GO  TO  1750 
A  DOLLAR  SIGN  (MULTIPLE  STATEMNTS)  SHIFT  LEFT 

=   LChARS  -  IDOLLAW 

=   LCHARS 
740   I   =   1.  LCHARS 
TE  (I)   =   ESTATE  (  IDOLLAR  ♦  I) 
TE  (lUOLLAR  ♦  I)   =   0 
1200  '         ; 

E  ARRAY  AND  RETURN  TO  START  THE  NEXT  RECORD. 
760   I   =   1.  LCHARS 
TE  (I)   =   IBLANK 

=    0  .        :       ,  ■ 

RANS  .EQ.  0)   GO  TO  1020 

=   TRANSF  (ITRANS,  72)  .    . 

=   1 
1070 
ESSING  FOLLOWING  A  RETURN  STATEMENT. 

=   0 
ALUE  .LE.  0)   GO  TO  9999  - 

=   NSTATN  ♦  1 
TATN  .GT.  MNSTATE)   GO  TO  1810 
(!♦  NSTATN)   =   NVALUE        i 
(2»  NSTATN)   =   9999 

=   1 
9999 


1790   IF  (LCHARS  .GT'.  3)   60  TO  1630  ■  '.  ' 
ICOUNT  (1.  1)   =   ICOUNT  (1.  1)  -  1 
■•  00  TO  9999 


1690 

IF  (NV 

1700 

NSTATN 

IF  (NS 

KSNUM 

IF  (J 

NSNUMC 

ISNUM 

KSNUM 

GO  TO 

1  71  0 

ISNUM 

KSNUM 

19999 

1720 

CALL  0 

17'30 

CALL  R 

NCARD 

IF  (ID 

HERE  FOR 

lcmars 

ICHARS 

'<■' 

DO  1 

LSTA 

17'4  0 

LSTA 

GO  TO 

CLEAR  TH 

1750 

DO  1 

176  0 

LSTA 

LCHARS 

IF  (IT 

.  .  j 

ITRANS 

' 

NCARD 

GO  TO 

END  PROC 

1770 

NCARD 

1780 

IF  (NV 

NSTATN 

J 

IF  (NS 

KSNUM 

KSNUM 

19999 

GO  TO 

-laoo- 


(LSTATE(I)f'  1=1 «  LCHARS) 
GO  rO  1630 


PRINT    50t  lERROR 
IF  (  ITYPE  .NE.  45) 
GO  TO  1750^     ■    ■   • 
810   PRINT    60.  MNSTATE 

.   PRINT    70.  (LSTATE(I).  1=1.  LCHARS) 
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READ331Q 
READ3320 
READ3330 
REA03340 
READ3350 
READ3360 
READ3370 
READ3380 
READ3390 
READ3400 
READ3410 
READ3420 
READ3430 
READ3440 
READ3450 
READ3500 
READ3510 
READ3520 
READ3530 
READ3540 
READ3550 
AND  GO  AGAINREAD3560 
READ3570 
READ3580 
READ3590 
READ3600 
READ3610 
•  READ3620 
READ3630 
READ3640 
REA03650 
READ3660 
REA03670 
READ3680 
READ3690 
READ3700 
READ3710 
REA03720 
READ3730 
READ3740 
READ3750 
READ3760 
READ3770 
READ3780 
READ3790 
READ3800 
REA03810 
REA03820 
REA03830 
REA03840 
READ3850 
REA03860 
READ3870 
READ3880 
READ3890 
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bUBwOuriNt   KtflDb  COC  6600  FTN  V3.0-P35b  0PT=1   06/^b/75   12.5S.39. 

C     DUMP  THt  f^tMAINUtK  Of  iHIb  HOUTlNt  HEA03900 

la^iO   PRINT    80.  LCAKO.  NAMt  HEAD3910 

kEwINC  LUbTATt                               -  PEAD39i;0 

IP^  -       7i                                                                                                                '  PEA03930 

390                   N   =   ?                                                      •  KEAD39^0 

C  •    ChECK  FOK  AN  tNO  bTATLMEM  '                    ■  HEAD3950 

1B30   IF  (CPECKltND.a.N.  IP^.LCAhfDd)  »IP3)  )   GU  TO  labO  PEAU3960 

C     ChECr  FOP  A  DOLLAP.  t.  blON  INDICAIINO  A  MULTIPLE  STAltMEKT.  PEAU3970 

IB'^O   N   =   ISCANl  (1PUNCT(6).  N  ♦  1.  72.  LCAPC  (1  )  )  ♦  1  HEAD3980 

395                   IF  (N  .LE.  /2)   GO  TO  1830  HEAD3990 

C     PEAD  THE  NEAT  PECOHD.                                        "  PEAU'iOOO 

HEAD  (LulN.    10)   LCAPC  PEAU4010 

ICOUNT  (1.  1)   =   ICOUNT  (1.  1)  ♦  1  PEAO'!»020 

IF  (EOF(LUIN))    1860.  1820  PEAU'.030 

400            C     END  FOUND.  PESET  AND  STAPT  THE  NEXT  POUTINE.  REAO4040 

1850   CALL  PESETS  PEA04050 

GO  TO  1000  READ4060 

C     EOF.  TEHMINATE  PEAD4070 

1860   lEOF   =   1  PEAU4080 

405                   ICOUNT  (1.  1)   =   ICOUNT  (1.  1)  -  1  PEAU4090 

.  9999   RfcTUPN  REAU4100 

C  PEAD4110 

10   FORMAT    (  lOOAl  )  PEAD4120 

20   FORMAT   (   «0EPPOP  IN  TPE  FIRST  5  COLUMNS  OF  THE  RECORD  «  eOAl  /  REA04130 

410  1    »  TPIb  RECORD  HAS  BEEN  LEFT  IN  THE  FINAL  ROUTINE  AS  A  COMMENT*  REA04140 

'   2    )  REAO4150 

30   FORMAT   (   "ONU  PROGRAM.  SUBROUTINE.  FUNCTION,  OR  BLOCK  DATA   ST«READ4160 

1  «ATEMENT  FOUND  ON  THE  INPUT  FILE  FOR  THIS  ROUTINE.*  /  READ4170 

2  «  CHECK  THE  FIRST  AND  LAST  TwO  RECORDb  OF  THIS  ROUTINE  BEFORE  •READ4ieO 
415                 3    ^COMPILATION."   )  READ4190 

'♦O  FORMAT  (  «0COULD  NOT  FIND  AN  EUUAL  SIGN  IS  THIS  REPLACEMENT  ST»READ4200 
1    »AT£MENT.*»  /  (IX.  130A1)  )  READ4210 

50   FORMAT   (   »0ERROR  IN  TPE  FOLLOWING  STATEMENT.  ITYPE  =  »  IS  /     READ4220 

1    (20X.  lOOAl)  )  REAO4230 

420  60   FORMAT   (   »OTHE  ARRAY  (KSNUM)  IS  FULL.   THE  NUMBER  OF  tXECUTAeL'»READ42^0 

1    "E  STATEMENT  NUMBERS  EXCEEDED  »  lb  )  READ42S0 

70   FORMAT   (   *OTHE  PREVIOUS  ERROR  FORCED  THE  TERMINATION  OF  PROCES«RE A04260 

1  *SINO  OF  THE  INPUT  FOR  THIS  ROUTINE  ON  STATEMENT*  /  (20X.       READ4270 

2  lOOAl)  )  READ4280 
425               80   FORMAT   (   »  THIS  INPUT  RECORD  NOT  PROCESSED  »  80A1  »   FOR  ROUT I»READ4290 

1    "NE  *  4A1  )  READ4300 

■C  REA04310 

END  REA04320 


I 
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SUBROUTINE   RESETS 
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10 


15 


20 


25 


30 


35 


40 


45 


50 


SUBROUTINE   RESETS 
:     THIS  ROUTINE  RESETS  ThE  POINTERS  ANO  COUNTERS. 

COMMON   /ALL/   ICHARS*  lOOLLARt  lERRORt  INNUM  (2*  50) •  IPOINT» 

1  IPROGt  ISNUM,  ITYPE,  19999.  KFORM  (100),  KFOUT  <3»  100),  KSNUM 

2  (2,  400),  LCARO  (80),  LCHARS,  LFOUT  (1000),  LSTATE  (2000), 

3  LWOROSf  NAME  (4),  NCAROS,  NEXT,  NFORMN,  NFOuT,  NKFORM,  NOUTS, 

4  NPUSH,  NSNUHC*  NSTATN,  NUMBER  (7),  NUMIN,  NUMK,  NVALUE,  STRING 

5  (2,  100) 

COMMON   /DATA/   C,  END,  H,  IBLANK,  lEOF,  INTEGER  (10),  IPUNCT 

1  (11),  ICOUNT  (2,  4),  LUIN,  LUOUT,  LUSTATE,  MFOUT,  MLCHARS, 

2  MNFORM,  MNSTATE,  NCARC,  NMAX,  NUMMAX,  PROGRAM  (7),  RETURN, 

3  STAR,  X 
INTEGER      STRING 

00  1000   I   =   1,  7 
1000     NUMBER  (I)   =   0 


00  1010   J   = 

1,  100 

00  1010   I 

=   1,  2 

1010 

STRING  (I,  J)   =   IbLANK 

00  1020   I   = 

1,  4 

1020 

NAME  (I)   =   IBLANK 

DO  1030   I   = 

1,  1000 

LFOUT  (I)   = 

IBLANK 

1030 

LSTATE  (I)   = 

IBLANK 

00  1040   J   - 

1,  100 

KFORM  (J)   = 

0 

DC  1040   I 

3   1.  3 

1040 

KFOUT  (I,  J) 

3   0 

DO  1050   I   = 

1,  4 

1050 

ICOUNT  (1,  I) 
ICHARS   =   0 
lERROR   s   0 
IPROG   3   0 
19999   =   0 
LCHARS   s   0 
NCAROS   =   0 
NEXT   =   1 
NFORMN   =   0 
NFOUT   =   0 
NKFORM   =   0 
NOUTS   3   0 
NSNUMC   =   990 
NSTATN   =   0 
NUMK   =   0 
ENTRY  RESETX 

=   0 

DO  1060   J   = 

1,  NUMMAX 

00  1060   I 

3    If  2 

1060 
9999 

INNUM  (I,  J) 
ISNUM   =   0 
ITYPE   =   1 
NVALUE   =   0 
NUMIN   =   0 
RETURN 
END 

3   0 

RESE 

10 

RESE 

20 

RESE 

30 

RESE 

40 

RESE 

50 

RESE 

60 

RESE 

70 

RESE 

80 

RESE 

90 

RESE 

100 

RESE 

110 

RESE 

120 

RESE 

130 

RESE 

140 

RESE 

150 

RESE 

160 

RESE 

170 

RESE 

180 

RESE 

190 

RESE 

200 

RESE 

210 

RESE 

220 

RESE 

230 

RESE 

240 

RESE 

250 

RESE 

260 

RESE 

270 

RESE 

280 

RESE 

290 

RESE 

300 

RESE 

310 

RESE 

320 

RESE 

330 

RESE 

340 

RESE 

350 

RESE 

360 

RESE 

370 

RESE 

380 

RESE 

390 

RESE 

400 

RESE 

410 

RESE 

420 

RESE 

430 

RESE 

440 

RESE 

450 

RESE 

460 

RESt 

470 

RESE 

480 

RESE 

490 

RESE 

500 

RESE 

510 

RESE 

520 

RESE 

530 
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SUBROUTINE   SMIFTH  COC  6600  FTN  V3.0-P355  OPT»l   06/2S/7S   12.55.39. 

SUBROUTINE   SHIFTR  (NEWt  ISTART.  ISTOPt  LIST) 
C     THIS  ROUTINE  SHIFTS  ALL  C*TA  IN  THE  LIST  FHQM  ISTART  THRU  ISTOP 
C       ONE  SPACE  TO  THE  RIGHT.   THE  CREATED  SPACE  IS  FILLED  BY  NEW. 
DIMENSION    LIST  (1) 
5  I   »   ISTOP 

1000   LIST  <I  *  1)   =   LIST  (I) 
1   =   1-1 

IF  (I  .GE.  ISTART)   GO  TO  1000 
LIST  (ISTART)   «   NEW 
10  ISTOP   =   ISTOP  ♦  1 

GO  TO  9999 
ENTRY  SHIFTL 
C     THIS  ROUTINE  SHIFTS  ALL  DATA  IN  THE  LIST  FROM  ISTART  THRU  ISTOP 
C       ONE  SPACE  TO  THE  LEFT.    THE  CREATED  SPACE  IS  FILLED  BY  NEW. 
15  C     NOTICE...   THE  VALUE  OF  ISTOP  IS  ADJUSTED. 

ISTOP   »   ISTOP  -  1 

IF  (ISTART  .6T.  ISTOP)   CO  TO  1020 
DO  1010   I   =   ISTART.  ISTOP 
1010     LIST  (I)   s   LIST  (I  *  1) 
20  1020   LIST  (ISTOP  *  1)   '   NEW 

9999   RETURN 
END 


SHIF 

10 

SUF 

20 

SHIF 

30 

ShU 

40 

SHIF 

SO 

SHII- 

60 

SHIf- 

70 

SHIK 

60 

SHIF 

90 

ShIF 

100 

SUF 

110 

SHIF 

120 

ShIF 

130 

SUF 

UO 

SHIF 

150 

Shlf 

160 

ShIF 

170 

SHIF 

leo 

SHIF 

190 

SHIF 

200 

SHIF 

210 

SHIF 

220 
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SUBROUTINE   SPflCOUT 


10 


15 


20 


25 


30 


35 


40 


45 


50 


55 


60 


65 


1000 
1010 


1020 
1030 


SUBKOUTINE   SPACOUT 
THIS  ROUTINE  INSERTS  THE 
COMMON   /ALL/   ICHARS. 

1  IPROGf  ISNUM»  ITYPE» 

2  (2.  400) .  LCARD  (80) 

3  LWOHDS*  NAME  (4),  NCA 

4  NPUSH.  NSNUMC»  NSTATN 

5  (2»  100) 

COMMON   /DATA/   C»  END» 

1  (11)  .  ICOUNT  (2»  4) » 

2  MNFORMt  MNSTATEt  NCAR 

3  STAR.  X 
DIMENSION    LIST:  {1.) 
INTEGER      H  : 
EQUIVALENCE   (LIST(l). 
II   =   IPOINT 

14     POSITION  OF  NEXT 

14   =    -  1000 

IFLAG   =   0 

IF  (II  .GT.  ICHARS)   GO 
DO  1020   J   =   1.  10 
IF  (LIST(II)  .EQ.  INT 
CONTINUE 

IF  (LIST(II) 


CDC  6600  FTN  V3.0-P355  OPT=I 


COMMON  SPACINGS.  ••  '    - 

IDOLLARv  TERROR.  INNUM  <2.  50).  IPOINT. 
19999.  KFORM  (100).  KF0UT.(3..  100).  KSNUM 
LCHARS.  LFOUT  (1000).  LSTATE  (2000). 
RDS.  NEXT.  NFORMN.  NFO.UT.  NKFORM.  NOUTS. 
NUMBER  (7).  NUMIN.  NUMK.  NVALUE.  STRING 

h.  IBLANK.  lEOF.  INTEGER  (10).  IPUNCT 
LUIN.  LUOUT.  LUSTATE.  MFOUT.  -MLCHARS. 
C.  NMAX.  NUMMAX.  PROGRAM  (7).  RETURN. 


LSTATE(i)) 
). 


TO  9999 
EeER(J))   GO  TO  1050 


(LIST(II)  .EQ.  IPUNCl 
(LIST(Il)  .EQ.  IPUNCl 


1040 


.EQ.  IPUNCT(l) )  GO  TO  1090 

T (2) )  GO  TO  1110 

T(3))  GO  TO  1120 

(LISTdl)  .EQ.  IPUNCT(5))  GO  TO  1090 

(LIST(II)  .EQ.  IPUNCT(9))  60  TO  1090 

(LISTdl)  .EQ.  IPUNCT(IO))  60  TO  1090 

=   II  ♦  1 


IF 
IF 
IF 
IF 
IF 
II 
60  TO  1000 


1050 
1060 


1070 

1080 
1090 


1110 


N   = 
II   = 
IF  (II 
IF  (LI 
00  1 
IF  ( 
CONT 
IF  (LI 
II   = 
GO  TO 
N   = 
GO  TO 
CALL  I 
CALL  I 
II   = 
14   = 
1100   IFLAG 
60  TO 
INSERT  A 
CALL  I 
II   = 
14   = 
00  TO 
IF  (14 


1120 
1130 


14   = 
GO  TO 
IF  (II 
14   = 
;     INSERT  B 
1140   IF  (IF 
CALL  I 
II   = 
14   = 
60  TO 
9999   RETURN 
END 


J  -  1 
II  + 
.GT. 
STdl 
070 
LIST( 
INUE 
STdl 
II  ♦ 
1000 
J  -  1 
1060 
NSERT 
NSERT 
II  ♦ 
14  ♦ 
=   1 
1010 
FTER 
NSERT 
II  ♦ 
14  ♦ 
1100 
•  GT. 
MATC 
1140 
.LT. 
-  1 
EFORL 
LAG 
NSERT 
II  ♦ 
14  ♦ 
1000 


I 

ICHARS)   GO  TO  9999 
)  .EQ.  IBLANK)   GO  TO  1060 
J   =   1.  10 
II)  .EQ.  INTEGER(J))   GO  TO  1080 

)  .NE.  H)   GO  TO  1030 
1  ♦  N 

♦  N  «  10 

(IBLANK.  II  ♦  1.  LCHARS.  LIST(l).  1) 
(IBLANK.  II.  LCHARS.  LISTd).  1) 
3 
2 


(IBLANK.  II  ♦  1.  LCHARS.  LIST(l).  1) 

2 

1 

0)   GO  TO  1130 
H  (II.  ICHARS.  LlST(l)) 

14)   GO  TO  1040 
000 

( 
EO.  1)   GO  TO  1040 

(IBLANK.  II.  LCHARS.  LISTd).  1) 

2 

1 
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12.55.39 

SPAC 

10 

SPAC 

20 

SPAC 

30 

SPAC 

40 

SPAC 

50 

SPAC 

60 

SPAC 

70 

SPAC 

80 

SPAC 

90 

SPAC 

100 

.. 

SPAC 

110 

SPAC 

120 

SPAC 

130 

SPAC 

140 

SPAC 

150 

SPAC 

160 

SPAC 

170 

SPAC 

180 

SPAC 

190 

SPAC 

200 

SPAC 

210 

SPAC 

220 

SPAC 

230 

SPAC 

240 

SPAC 

250 

SPAC 

260 

SPAC 

270 

SPAC 

280 

SPAC 

290 

SPAC 

300 

SPAC 

310 

SPAC 

320 

SPAC 

330 

SPAC 

340 

SPAC 

350 

SPAC 

360 

SPAC 

370 

SPAC 

380 

SPAC 

390 

SPAC 

400 

SPAC 

410 

SPAC 

420 

SPAC 

430 

SPAC 

440 

SPAC 

450 

SPAC 

460 

SPAC 

470 

SPAC 

480 

SPAC 

490 

SPAC 

500 

SPAC 

510 

SPAC 

520 

SPAC 

530 

SPAC 

540 

SPAC 

550 

SPAC 

560 

SPAC 

570 

SPAC 

580 

SPAC 

590 

SPAC 

600 

SPAC 

610 

SPAC 

620 

SPAC 

630 

SPAC 

640 

SPAC 
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SPAC 

660 

SPAC 

670 

SPAC 

680 
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FUNCTION     SPWESS  CDC  6600  FTn  V3.0-P355  OPT^l 

FUNCTION   SPRESS  (It  ISTOP,  LIST) 
C    THIS  ROUTINE  SURPRESSES  ALL  BLANKS. 
DIMENSION    LIST  (l) 
DATA     IB  /  IH    / 
5  SPHESS   =   0.0 

1000   IF  (I  .GT.  ISTOP)   GO  TO  1010 

IF  (LIST(I)  .NE.  IB)   GO  TO  9999 
C     SUHPRESS  ANY  STRAY  BLANKS. 

CALL  ShIFTL  (IBt  I.  ISTOP.  LIST(l)) 
10  GO  TO  1000 

1010   SPRESS   =   1.0 
9999   RETURN 
END 


06/25/75   12.55.39 

SPRE 

10 

SPRt 

20 

SPRE 

30 

SPRE 

40 

SPRE 

50 

SPRE 

60 

SPRE 

70 

SPRE 

80 

SPRE 

90 

SPRE 

100 

SPRE 

110 

SPRE 

120 

SPRE 
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SUBROUTINE   STORE 
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10 


15 


20 


25 


30 


35 


AO 


^5 


50 


55 


SUbROUTINE  STOWE  (JTYPE 
C  THIS  ROUTINE  ADDS  DIMENSI 
C       THE  ARRAY  STRING. 

COMMON   /ALL/   ICHARS,  I 

1  IPR06,  ISNUM,  ITYPE.  I 

2  (2.  ^00).  LCARD  (80). 

3  LWORDS»  NAME  (4) »  NCAR 

4  NPUSH.  NSNUMC.  NSTATN. 

5  (2.  100) 

COMMON   /DATA/   C»  END. 

1  (11).  ICOUNT  (2.  4).  L 

2  MNFORM.  MNSTATE.  NCARC 

3  STAR.  X 

DIMENSION    ITESTN  (  7). 
INTEGER      STRING 
EQUIVALENCE   (II.  IPOINT 
C     RANGE  OF  THE  LOCATIONS  Nl 
N   =   0 

DO  1000   I   =   1.  JTYP 

1000     N   =   N  ♦  NUMBER  (I) 

Nl   =   N  -  NUMBER  (jTYPE 

1010  13  =  ISCANL  (IPUNCTO) 
IS  =  ISCANL  (IPUNCT(2) 
IF  (I3-IS-1)    1020.  103 

1020  CALL  INSERT  (IBLANK.  13. 
IS  =  MATCH  (13  ♦  1.  IS 
GO  TO  1040 

1030   IS   =   ISTOP 

1040  LENGTH  =  MINO  (20.  IS 
IF  (LENGTH  .LE.  0)  GO  T 
NEWORD  (1)  =  IBL 
NEKORC  (2)  =  IBL 
ENCODE  (LENGTH.  10.  NE 
DECODE  (  7.    10.  NEWORD 


) 

ON  AND  TYPED  VARIABLES  OF 

DOLLAR.  TERROR.  INNUM  (2. 
9999.  KFOKM  (100).  KFOUT  ( 
LCHARS.  LFOUT  (1000).  LSTA 
DS.  NEXT.  NFORMN.  NFOUT.  N 
NUMBER  (7).  NUMIN.  NUMK. 

H.  IBLANK.  lEOF.  INTEGER  ( 
UIN.  LUOUT.  LUSTATE.  MFOUT 
»  NMAX.  NUMMAX.  PROGRAM  (7 

ITESTNl  (  7).  LIST  (1).  N 

).  (ISTOP.  ICHARS).  (LIST( 
THRU  N. 


)  ♦  1 

.  II.  ISTOP.  LIST  (1) ) 

.  II.  ISTOP.  LIST(l))  -  1 

0.  1040 

LCHARS.  LIST(l) .  1) 
TOP.  LIST(l)) 


IF  (N  .LT.  Nl)   GO  TO  10 
C     CHECK  IF  THIS  VARIABLE  IS 
C       IF  SO  DROP  IT. 

DO  1050   J   =   Nl,  N 


-  II  ♦  1) 

0  9999 

ANK 

ANK 

WORD  (1))  (LIST  (K 

(1))  ITESTN 

60 
ALREADY  PRESENT  IN  THE  STR 


IF  (NEWORO(i) 
1050     CONTINUE 
;     PUSH  DOWN  THE  STRING. 
1060   K   =   NUMK   =   NUMK  ♦  1 
IF  (NUMK  .LE.  NMAX)   GO 
PHINT    20.  NEWOKD 
GO  TO  9999 
1070   IF  (K  .LE.  Nl)   GO  TO  10 

DO  1080   I   =   1.  2 
lOao     STRING  (I.  K)   =   STRI 
K   =   K  -  1 

IF  (K  .GT.  N)   GO  TO  10? 
:     INSERT  THE  NEW  VARIABLE  DE 
1090   NN   =   N   =   N  ♦  1 

NUMBER  (JTYPE)   =   NUMBE 
DO  1100   I   =   1.  2 
IIUO     STRING  (I.  N)   =   NEWC 


.EG.  STRINGd.J))   GO  TO  1150 


TO  10/0 

90 

NG  (I.  K  -  1) 

0 
FINITION. 

R  (JTYPE)  ♦  1 

KD  (I) 


STOR   10 

TYPE  JTYP  TO 

STOR   20 

STOR   30 

50).  IPOINT. 

STOR   40 

3,  100).  KSNUM 

STOR   50 

TE  (2000). 

STOR   60 

KFORM,  NOUTS. 

STOR   70 

NVALUE.  STRING 

STOR   80 

STOR   90 

10).  IPUNCT 

STOR  100 

.  MLCHARS. 

STOR  110 

).  RETURN. 

STOR  120 

STOR  130 

EWORO  (2) 

STOR  140 

STOR  150 

1) .  LSTATE(l) ) 

STOR  160 

STOR  180 

STOR  190 

STOR  200 

STOR  210 

STOR  220 

STOR  230 

STOR  240 

STOk  250 

STOR  260 

STOR  270 

STOR  280 

STOR  290 

STOR  300 

STOR  310 

STOR  320 

STOR  330 

).  K=II.  IS) 

STOR  340 

STOR  350 

STOR  360 

ING. 

STOR  370 

STOR  380 

STOR  390 

STOR  400 

STOR  410 

STOR  420 

STOR  430 

STOR  440 

STOR  450 

STOR  460 

STOR  470 

STOR  480 

STOR  490 

STOR  500 

STOR  510 

STOR  520 

STOR  530 

STOR  540 

STOR  550 

STOR  560 

49 
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1110   IF  (NN  .LE.  Nl)   GO  TO  1150  STOR  570 

NN   =   NN  -  1  STOR  580 

DECODE  (  7.    10.  STRING  (1.  NN) )   ITESTNl  STOR  590 

LENGTH   =   MING  (LENGTH.  7)  STOR  600 

60                     DO  1120   I   =   1.  LENGTH  STOR  610 

IF  (ITESTNKI)  .EQ.  I8LANK)   GO  TO  1150  STOR  620 

IF  (ITESTN(I)  .EO.  IBLANK)   GO  TO  1130  STOR  630 

IF  (ITESTN(I)   -    ITESTNKI))  1130»  1120t  1150                STOR  640 

1120     CONTINUE  STOR  660 

65             1130     DO  1140   1=1.2  STOR  670 

STRING  (I.  NN  ♦  1)   =   STRING  (I.  NN)  STOR  680 

1140     STRING  (I.  NN)   =   NEWORD  (I)  STOR  690 

GO  TO  1110  STOR  700 

1150   II   =   IS  ♦  2  STOR  710 

70                  IF  (II  .LE.  ISTOP)   60  TO  1010  STOR  720 

9999   RETURN  STOR  730 

C  STOR  740 

10   FORMAT   (  lOOAl  )  STOR  750 

20   FORMAT   (   »OTHE  ARRAY  STRING  IS  FULL.  THE  VARIABLES  STARTING  WI*STOR  760 

75                1    ''Th  »  2A10  »  WERE  DROPPED.**   )  STOR  770 

C  STOR  780 

END  STOR  790 
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SUBROUTINE   SUMMARY 

SUHM 

10 

C     THIS  ROUTINE  PRODUCES  THE  SUMMARY  REPORT  AFTER  EACH  ROUTINE  HAS 

SUMM 

20 

C 

BEEN  PROCESSED. 

SUMM 

30 

COMMON   /ALL/   ICHAKS,  IDOLLAR.  lERHOR.  INNUM  (2»  50) 

1.  IPOINT. 

SUMM 

40 

1 

IPROG,  ISNUM,  ITYPE.  19999.  KFORM  (100).  KFOUT  (3. 

100).  KSNUM 

SUMM 

50 

2 

(2.  400).  LCARO  (80).  LChARb,  LFOUT  (1000).  LSTATE 

(2000)  . 

SUMM 

60 

3 

LWORDS.  NAME  (4).  NCAHDS.  NEXT.  NFORMN.  NFOUT.  NKFORM,  NOUTS. 

SUMM 

70 

4 

NPUSH.  NSNUMC.  NSTATN.  NUMBER  (7).  NUMIN.  NUMK,  NVALUE.  STRING 

SUMM 

80 

5 

(2.  100) 

SUMM 

90 

COMMON   /DATA/   C.  END.  H.  IBLANK.  lEOF.  INTEGER  (10) 

i.  IPUNCT 

SUMM 

100 

1 

(11).  ICOUNT  (2.  4).  LUIN,  LUOUT.  LUSTATE.  MFOUT,  MLCHARS, 

SUMM 

110 

2 

MNFORM.  MNSTATE.  NCARC.  NMAX,  NUMMAX,  PROGRAM  (7). 

RETURN. 

SUMM 

120 

3 

STAR.  X 

SUMM 

130 

DIMENSION    PER  (2*2) 

SUMM 

140 

INTEGER      PKOGRAM 

SUMM 

150 

DO  1000   J   =   1.  3 

SUMM 

160 

1000 

ICOUNT  (2.  J)   =   ICOUNT  (2.  J)  ♦  ICOUNT  (1,  J) 

SUMM 

170 

DO  1010   I   =   1.  2 

SUMM 

180 

1010 

ICOUNT  (I.  4)   =   ICOUNT  (I.  2)  -  ICOUNT  (I.  3) 

SUMM 

190 

00  1040   I   =   1.  2 

SUMM 

200 

DO  1020   J   =   1.  2 

SUMM 

210 

1020 

PER  (I.  J)   =   0.0 

SUMM 

220 

IF  (IC0UNT(I.2)  .EO.  0)   GO  TO  1040 

SUMM 

230 

DO  1030   J   =   1.  2 

SUMM 

24  0 

1030 

PER  (I.  J)   =   100.  «  ICOUNT  (I.  J  ♦  2)  /  ICOUNT 

d.  2) 

SUMM 

250 

lO'^O 

CONTINUE 

SUMM 

260 

PRINT    10.  NAME.  PROGRAM.  (dCOUNTd.  J).  1  =  1.  2).  J=l.  2).  ( 

SUMM 

270 

1 

(ICOUNTd.  J  ♦  2).  PEh(I.  J).  1  =  1.  2).  J  =  l.  2) 

SUMM 

280 

IF  (NFORMN  .LE.  0)   GO  TO  1050 

SUMM 

290 

PRINT    20.  (J.  KFORM(J).  J=l,  NFORMN) 

SUMM 

300 

GO  TO  1060 

SUMM 

310 

1050 

PRINT    30 

SUMM 

320 

1060 

IF  (NSTATN  .LE.  0)   GO  TO  1070 

SUMM 

330 

PRINT    40.  ((KSNUMd.  j).  1  =  1.  2).  J=l.  NSTATN) 

SUMM 

340 

GO  TO  9999 

SUMM 

350 

1070 

PRINT    50 

SUMM 

360 

999S 
C 

RETURN 

SUMM 
SUMM 

370 
380 

10 

FORMAT   (   »0COUNTER  SUMMARY"  44X,   «FOR  ROUTINE  »  4A1.  24X. 

SUMM 

390 

1 

"CUMMULATIVE  FOR  PROGRAM  »  7A1  //  36X.  2(30X.   "PERCENT    «  ) 

/SUMM 

400 

2 

46X.  2(20X.   "OUTPUT                «  )  /   "ONUMBER  OF  INPUT  REC 

"SUMM 

410 

3 

"ORDS.                  »  2(120.  20X)  /   «  NUMBER  OF 

OUTPUT  RECO 

"SUMM 

420 

4 

"RDS.                 "  2(120.  20X)  /   ■»  NUMBER  OF  COMMENT  STATE 

"SUMM 

430 

5 

^MENTS.             "  2(120.  FlO.l.  lOX)  /   "  NUMBER 

OF  VALID  EX 

"SUMM 

440 

6 

"ECUTABLE  STATEMENTS.   "  2(120.  FlO.l.  lOX)  ) 

SUMM 

450 

20 

FORMAT   (   "OFORMAT  STATEMENT  NUMBER  INDEX 

NEW/OLD" 

SUMM 

460 

1 

2X.  6(Ib  "0/"  15)  /  (10(16  "0/"  15))  ) 

SUMM 

470 

30 

FORMAT   (   "OTHIS  ROUTINE  USES  NO  FORMAT  STATEMENTS" 

) 

SUMM 

480 

^0 

FOKMAT   (   "OEXECUTABLt  STATEMENT  NUMBER  INDEX 

OLD/NEW" 

SUMM 

490 

1 

2X»  6(17  "/"  IS)  /  (10(17  "/«  15))  ) 

SUMM 

500 

50 

FOKMAT   (   "OTHIS  ROUTINE  USES  NO  EXECUTABLE  STATEMENT  NUMBERS" 

SUMM 

510 

1 

) 

SUMM 

520 

C 

SUMM 

530 

END 

SUMM 

540 
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FUNCTION     TNANSF                                   CDC  6600  FTN  V3.0-P355  0PT=1  06/2b/75   12.55.39. 

INTEGtKFUNCriON   THANSF  (U.  12)  IRAN   10 

c    This  houtine  transfers  the  data  record  from  icard  to  istate.  tran  20 

COMMON   /all/   IChARS.  IDOLLAR.  lERROR.  INNUM  (2,  50) •  IPOINT»  TRAN   30 

1  IPROG.  ISNUM.  ITYPE.  19999.  KFORM  (100).  KFOUT  (3.  100).  KSNUH  TRAN   ^0 
5                2    (2.  ^00).  LCARO  («0).  LCHARS.  LFOUT  (1000).  LSTATE  (2000).  TRAN   50 

3    LWOROS.  NAME  Ct).  NCANDS.  NEXT,  NFORMN.  NFOuT.  NKFORM.  NOUTS.  TRAN   60 

^    NPUSH.  NSNUMC.  NSTATN.  NUMBER  (7).  NUMIN.  NUMK.  NVALUE.  STRING  TRAN   70 

5    (2.  100)  TRAN   80 

COMMON   /DATA/   C.  END.  H.  IBLANK.  lEOF.  INTEGER  (10).  IPUNCT  TRAN   90 

10                1    (11).  ICOUNT  (2.  4).  LUIN.  LUOUT.  LUSTATE.  MFOUT.  MLCHARS.  TRAN  100 

2  MNFCRM,  MNSTATE,  NCARC.  NMAX,  NUMMAX.  PROGRAM  (7).  RETURN,  TRAN  HO 

3  STAR.  X  TRAN  120 
TRANSF   =   0  TRAN  130 

DO  1000   1   =   11.  12  TRAN  140 

15                    IF  (LCHARS  .GE.  MLCHARS)   GO  TO  1010  TRAN  150 

LCHARS   =   LCHARS  ♦  1  TRAN  160 

1000     LSTATE  (LCHARS)   =   LCARO  (I)  TRAN  170 

bO  TO  1020  TRAN  160 

1010   PRINT    10.  MLCHARS,  LCARD  TRAN  200 

20                  TRANSF   =   I  TRAN  210 

LCHARS   =   MLCHARS  TRAN  220 

1020   ICHARS   =   LCHARS  TRAN  230 

9999   RETURN  TRAN  240 

C  TRAN  250 

25  10   FORMAT   (   «OTHE  ARRAY  (LSTATE)  IS  FULL.  THE  NUMBER  OF  CHAR ACTER»TR AN  260 

1  «S  IN  THE  CURRENT  STATEMENT  EXCEEDED  »  15  /   <*0THE  ARRAY  LSTAT»TRAN  270 

2  *E  OVERFLOWED  ON  CARD     «  dOAl  )  TRAN  280 
C  TRAN  290 

END  TRAN  300 
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SUBROUTINE   WRITES 
THIS  ROUTINE  CONTROLS  THE  WRITING  OF  THE  OUTPUT  FILE 
COMMON   /ALL/   ICHARS.  lOOLLARt  lERROR.  INNUM  (2. 

1  IPROGt  ISNUM.  ITYPE*  19999.  KFORM  (100).  KFOUT  ( 

2  (2.  400).  LCARD  (80).  LCHARS.  LFOUT  (1000).  LSTA 

3  LWORDS.  NAME  (4),  NCAfiDS.  NEXT.  NFORMN,  NFOUT.  N 

4  NPUSH.  NSNUMC.  NSTATN,  NUMBER  (7).  NUMIN.  NUMK, 

5  (2.  100) 
COMMON   /DATA/   C.  END.  H.  IBLANK.  lEOF.  INTEGER  ( 

1  (11).  ICOUNT  (2.  4).  LUIN.  LUOUT.  LUSTATE.  MFOUT 

2  MNFORM.  MNSTATE.  NCARC.  NMAX.  NUMMAX,  PROGRAM  (7 

3  STAR.  X 
KCARO  (200).  NPSTACK  (10) 


1000 


DIMENSION 
INTEGER 
IFLAG   =   0 
IN   =   0 
NOLDTYP   =   0 
NPUFLAG   =   0 
NPUSH   =   0 
REWIND  LUSTATE 
IF  (NOUTS  .LE. 
READ  (LUSTATE) 


1 


1010 


1020 


1030 


1040 


C.  END.  H.  RETURN,  STAR.  X 


0)   GO  TO  9999 
NTYPE. LWORDS. 


NUMIN.  (  (INNUMd.  J).  1  =  1. 

IF  (EOF(LUSTATE) )    1220.  1010 

NOUTS   =   NOUTS  -  1 

DO  1020   I   =   1.  1000 
LSTATE  (I)   =   IBLANK 


ICi 
2)1 


ISNUM.  (KCARD(I) 
J=l.  NUMIN) 


IF  (NTYPE  .EQ.  0)   GO  TO  1190 

IFLAG   =   0 

IF  (NTYPE  .GE.  15  .AND.  NOLDTYP 

.LE.  6)   CALL  OUTS 

NOLDTYP   =   NTYPE 

LCHARS   =   IC  ♦  7 

IF  (IC  .GT.  100)   GO  TO  1030 

IF  (IC  .LE.  0)   GO  TO  1000 

DECODE  (IC.    10.  KCARD  (D) 

(LSTATE  (I).  1=8,  L 

GO  TO  1050 

II   =   1 

11   =   8 

12   =   MINO  (11  ♦  99.  LCHARS) 

ICC   =   MINO  (IC.  100) 

IF  (ICC  .LE.  0)   GO  TO  1050 

DECODE  (ICC.    10.  KCARC  (ID) 

(LSTATE  (I).  1=11 

IC   =   IC  -  100 

II   =   10  ♦  II 

11   =   100  ♦  11 

IF  (IC  .GT.  0)   GO  TO  1040 

1050   IF  (NTYPE  .NE.  18)   GO  TO  1060 
C     RECORD  THE  DO  LOOP  TERMINAL  POINT  STATEMENT  NUMBER. 
NPUSH   =   NPUSH  ♦  1 
NPSTACK  (NPUSH)   =   INNUM  (2.  1) 
1060   IF  (ISNUM  .EQ.  0)   GO  TO  1120 
C     LABEL  THE  NEW  STATEMENT  NUMBER 
ENCODE  (5.    20.  L)   ISNUM 
DECODE  (5.    10,  L)    (LSTATE(I).  1=1,  5) 
IF  (NPUSH  .EQ.  0)   GO  TO  1120 


WRIT   10 

AND  REPORT. 

WRIT   20 

50).  IPOINT, 

WRIT   30 

3.  100).  KSNUM 

WRIT   40 

TE  (2000). 

WRIT   SO 

KFORM,  NOUTS, 

WRIT   60 

NVALUE,  STRING 

WRIT   70 

WRIT   80 

10),  IPUNCT 

WRIT   90 

,  MLChARS, 

WRIT  100 

),  RETURN, 

WRIT  110 

WRIT  120 

WRIT  130 

WRIT  140 

WRIT  150 

WRIT  160 

WRIT  170 

WRIT  180 

WRIT  190 

WRIT  200 

WRIT  210 

,  1=1,  LWORDS) 

,WRIT  220 

WRIT  230 

WRIT  240 

WRIT  250 

WRIT  260 

WRIT  270 

WRIT  280 

WRIT  290 

TR 

WRIT  300 

WRIT  310 

WRIT  320 

WRIT  330 

WRIT  340 

CHARS) 

WRIT  350 

WRIT  360 

WRIT  370 

WRIT  380 

WRIT  390 

WRIT  400 

WRIT  410 

,  12) 

WRIT  420 

WRIT  430 

WRIT  440 

WRIT  450 

WRIT  460 

WRIT  470 

WRIT  480 

WRIT  490 

WRIT  500 

WRIT  510 

WRIT  520 

WRIT  530 

WRIT  540 

WRIT  550 
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60 


65 


70 


75 


80 


8b 


90 


95 


iOO 


105 


110 


C     CHECK  FOR  THE  DO  LOOP  TERMINATION  STATEMENT  NUMBER. 
NPU   =   NPUSH 

DO  1070   J   =   1.  NSTATN 
IF  (KSNUM(2,J)  .EQ.  ISNUM)   GO  TO  1080 
1070     CONTINUE 
GO  TO  1120 
1080     DO  1090   I   =   If  NPU 

IF  (NPSTACK(I)  .EQ.  KSNUM(1,J))   GO  TO  1100 
1090     CONTINUE 
GO  TO  1120 
C     IF  THIS  IS  A  TERMINATION  STATEMENT  REDUCE  ThE  PUSH  COUNT  AND 
1100   NPUFLAG   =   NPUFLAG  ♦  1 
NPU   =   NPUSH  -  NPUFLAG 
DO  1110   II   =   I.  NPU 
1110     NPSTACK  <II)   =   NPSTACK  (II  ♦  1) 

IF  (NPU  .GE.  I)   GO  TO  1080 
1120   IF  (NUMIN  .LE.  0)   GO  TO  1180 
C     INSERT  ALL  REVISED  INTERNAL  STATEMENT  NUMBERS 
DO  1130   J   =   1.  NSTATN 

IF  (  INNUM(2, NUMIN)  .EQ.  KSNUM(1,J))   GO  TO  1150 
1130     CONTINUE 

DO  1140   J   =   li  NFORMN 

IF  (INNUM(2. NUMIN)  .E(3.  KFORM(J))   GO  TO  1160 
1140     CONTINUE 

PRINT    30«  INNUM  (2»  NUMIN) 

CALL  INSERTN  (INNUM(2»  NUMIN),  INNUMd,  NUMIN)  ♦  7.  LCHARSi 
1    LSTATEd).  0) 
GO  TO  1170 
1150   CALL  INSERTN  (KSNUM(2,  j),  INNUMd,  NUMIN)  ♦  7,  LChARS, 
1    LSTATEd),  0) 
GO  TO  1170 
1160   CALL  INSERTN  (J  »  10,  INNUMd,  NUMIN)  ♦  7»  LCHARS,  LSTATEd 
1170   NUMIN   =   NUMIN  -  1 
GO  TO  1120 
C 

1180   IF  (NPUSH  .LE.  0)   GO  TO  1200 
C     PUSH  OVER  The  statement  as  REQUIRED. 

CALL  INSERT  (IBLANK,  8,  LCHARS,  LSTATEd),  2  •  NPUSH) 
GO  TO  1200 
C     PROCESS  A  COMMENT  STATEMENT. 
1190   IC   =   MINO  (IC,  72) 
LChARS   =   IC 

ICOUNT  (1,  3)   =   ICOUNT  (1,  3)  ♦  1 
C     SKIP  DOUBLE  BLANK  REORDS  IN  SUCCESSION. 

IF  (IFLAG  .EQ.  1  .AND.  IC  .LE.  1)   GO  TO  1210 

IFLAG   =   0 

IF   (IC  .LE.  1)   IFLAG   =   1 

DECODE  dC,    10,  KCARD  (D)    (LSTATE  (I),  1  =  1,  IC) 


1200   IF  (NTYPE  .EQ.  36  .AND.  NOUTS  .EQ. 

IF  (NTYPE  .EQ.  21)   CALL  IFSPACE 

CALL  PUNCHIT  (NTYPE) 
1210   NPUSH   =   NPUSH  -  NPUFLAG 

NPUFLAG   =   0 

IF  (NOUTS  .GT.  0)   GO  TC  1000 


0)   GO  TO  1230 


MRU 

560 

WRIT 

570 

WRIT 

580 

MRU 

590 

WRIT 

600 

wRII 

610 

WRIT 

620 

WRIT 

630 

WRIT 

640 

WRU 

650 

THE 

STWRIl 

660 

WRII 

670 

WRIT 

680 

WRII 

690 

WRI1 

700 

WRIT 

710 

WRIT 

720 

WRIT 

730 

WRII 

740 

WRIT 

750 

WRIT 

760 

WRII 

770 

WRIT 

780 

WRII 

790 

WRIT 

800 

WRIT 

810 

WRI1 

820 

WRII 

830 

WRII 

840 

WRIT 

850 

WRII 

860 

>, 

4)  WRIT 

870 

WRII 

880 

WRIT 

890 

WRI1 

900 

WRI1 

■  910 

WRII 

920 

WRII 

930 

WRn 

■  940 

WRIT 

950 

WRII 

960 

WRII 

970 

WRII 

980 

WRIT 

990 

WRII 

1000 

WRIT 

1010 

WRIT 

1020 

WRII 

1030 

WRII 

1040 

WRII 

1050 

WRII 

1060 

WRII 

1070 

WRIT 

1080 

WRIT 

1090 

WRIT 

1100 
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.  1220   IF  (IPROG  .GE.  4  .OR.  IPROG  .LE.  1)   GO  TO  1280                  WRITlllO 

IF  (NTYPE  .EQ.  20  .AND.  19999  .EQ.  0)   GO  TO  1280  WRIT1120 

GO  TO  1250  WRIfll30 

1230     DO  1240   I   =   1.  LCHAKS  WRIT1140 

115             1240     LSTATE  (I)   =   IBLANK  WP1T1150 

ICHARS   =   LCHARS   =   0  WRIT1160 

1250   CALL  INSERT  (RETURN,  1,  LCHARS,  LSTATE(l),  8)                    WRIT1170 

IF  (19999  .EQ.  0)   GO  TO  1260  WRIT1180 

CALL  INSERT  (IBLANK,  1,  LCHARS,  LSTATE(l),  2)                    WRIT1190 

120                  CALL  INSERTN  (9999,  1,  LCHARS,  LSTATE(l),  4)  WRIT1200 

GO  TO  1270  WRIT1210 

1260   CALL  INSERT  (IBLANK,  1,  LCHARS,  LSTATE(l),  7)                      WRIT1220 

127Q   CALL  PUNCHIT  (99)  WRIT1230 

1280   CALL  OUTFRM  WRIT1240 

125                  CALL  INSERT  (END,  1,  LCt-ARS,  LSTATE(l),  3)  WRIT1250 

CALL  INSERT  (IBLANK,  1,  LCHARS,  LSTATE(l),  7)                    WRIT1260 

CALL  PUNCHIT  (100)  WRIT1270 

REWIND  LUSTATE  WRIT1280 

ICOUNT  (1,  2)   =   ICOUNT  (1,  2)  ♦  NCARDS  WRIT1290 

130                   CALL  SUMMARY  WRIT1300 

9999   RETURN  WRIT1310 

C  WRIT1320 

10   FORMAT   <  lOOAl  )  WRIT1330 

20   FORMAT   (  15  )  WRIT1340 

135  30   FORMAT   (   «OSTATEMENT  NUMBER  «  16  «  WAS  USED  INTERNALLY  IN  A  BU»WRIT1350 

1  «T  IT  WAS  NOT  USED  AS  STATEMENT  LABEL.   THE  ORIGINAL  VALUE  WAS»WRIT1360 

2  «  REINSERTED.  »   )  WRIT1370 
C  WRIT1380 

END  WRIT1390 
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«  IMPORTANT  NOTICE,. .AUDITRS  WILL  ABORT  IF  THE  CL  PARAMETER  ON  YOUR    » 

♦  JOB  CARD  IS  LESS  THAN  AlOOO.  * 

NOTICE  TO  ALL  USERS    ♦ 

♦  COBOL 

♦  COBOL  HAS  BEEN  BACKED  UP  TO  LEVEL  336 

♦  ANY  USER  WHO  HAD  PROBLEMS  WITH  COBOL  LEVEL  365 

♦  PLEASE  CALL  EXT.  4784 

♦  NOTICE. ..THE  RUN  COMPILER  HAS  BEEN  UPDATED  TO  PSR  LEVEL  380.         * 

06/25/75   M.I.P.C.  SERIAL  121  SCOPE  3.3  L355.126 
12.54,36.CKGH0HA 

12.54,36.IP   000001  INPUT  UNITS  USED. 
12.54.36.$SEQUENCE»KGH. 
12.54,36. 

12.54.36.$CHARGE»T1308   -060. 
12.54.36. 

12.54,36.GETUM,CM12000»MT1»P4»T30»CL55000. 
12.54,36. 

i2.54.36,LABEL»TAPEl»R»L=USBMSEPPANEN,VSN=X1851. 
12. 54, 38, MT  50  ASSIGNED  TO  TAPEl 
12.55,29,  MT  50  VISUAL  REEL  NUMBER  IS   0X1851 
12.55,29,  LABEL  READ  WAS 
12.55,29,USBMSEPPANEN 
12.55,29,    EDITION  NUMBER    01 
12.55,29,    RETENTION  CYCLE   000 
12,55,29,    CREATION  DATE     75168 
12.55.29.    REEL  NUMBER       0001 
12.55.29.SKIPr»TAPEl»8»17,B. 
12.55.35.C0PYBF(TAPE1»B) 
12. 55. 36. FILE  OPENED  -  6 
12.55.38.REWIN0*6. 
12.55.38.RFL*55000. 

12.55. 39. CM   012000      CM  CELLS  USED. 
12. 55. 39. CP   000000.054  CP  SEC.  USED. 
12.55.39.10   000011.119  10  SEC.  USED. 
12. 55. 39. SS   000000.466  SYSTEM  SEC.  USED. 
12.55. 39. FTN»I=B»R=0. 
12. 55. 39. FILE  OPENED  -  COMPS 
12. 55. 39. FILE  OPENED  -  OUTPUT 
12. 55. 39. FILE  OPENED  -  FTNRLST 
12. 55. 39. FILE  OPENED  -  LGO 

12.56,36, IP   000001  STORAGE  DATA  BLOCKS  ON  FILE   INPUT 
12, 56, 36, OP   000167  STORAGE  DATA  BLOCKS  ON  FILE   OUTPUT 
12. 56, 36, CM   055000      CM  CELLS  USED. 
12. 56. 36. CP   000021.880  CP  SEC.  USED. 
12.56.36.10   000047.522  10  SEC.  USED. 
12. 56. 36. SS   000019.703  SYSTEM  SEC.  USED. 
12. 56. 36. AC  -   END  OF  JOB. 
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APPENDIX  B. --FUNCTION  AND  SUBROUTINE  DESCRIPTIONS 


Routine 


REOR 


Description 

The  main  control  routine.   Establishes  common  values  and 
controls  the  operation  cycles.   Calls  RESETS,  READS,  and 
WRITES  for  each  Fortran  routine.   Terminates  with  a  call 
to  EXIT  after  an  EOF  has  been  encountered. 


BLANKS 


A  subroutine  used  to  suppress  blank  spaces  in  the  statement 
text.   It  offers  special  handling  to  the  Hollerith  fields 
in  DATA  and  FORMAT  statements.   Uses  following  routines: 

INSERT,  INSERTN,  NONR,  and  SHIFTL. 


CHECK  (L00K4,  NN,   A  logical  function  that  indicates  whether  the  character 


ISTART,  ISTOP, 
LIST,  IPOINT) 


string  L00K4,  of  length  NN  characters,  was  found  in  array 
LIST  between  the  columns  ISTART  and  ISTOP.   Spaces  in  the 
LIST  are  suppressed.   The  position  of  the  next  character 
beyond  the  string  identified  is  returned  as  IPOINT.   Uses 
routine  SHIFTL. 


FIXDATA 


A  subroutine  used  to  assure  that  the  proper  spacing  is 
retained  in  DATA  statement  Hollerith  fields. 


IDENT  (N) 


A  function  that  identifies  the  statement  type.   N  indicates 
whether  to  look  for  a  routine  identification  statement 
(N  =  1)  or  subsequent  statement  (N  =  2) .   Uses  routine 
SHIFTL. 


IFSPACE 

INSERT  (NEW, 
ISTART,  ISTOP. 
LIST,  N) 


A  subroutine  used  to  insert  spacing  in  IF  statements. 

A  subroutine  used  to  insert  the  character  string  NEW,  of 
length  N  characters,  into  the  array  LIST  immediately  prior 
to  ISTART.   ISTOP  indicates  the  upper  range  limit  for  LIST 
that  must  be  shifted  to  make  room  for  the  new  characters. 
It  adjusts  the  statement  number  array  INNUM  to  compensate 
for  the  inserted  characters.   Uses  routine  SHIFTR. 


INSERTN 


An  entry  in  subroutine  INSERT  that  inserts  into  LIST  the 
character  equivalent  of  the  integer  NEW.   N  is  assumed  to 
be  5. 


INSERTS 


An  entry  in  subroutine  INSERT  that  does  the  identical  pro- 
cessing less  the  statement  number  readjustment  in  array 
INNUM. 


ISCANL 


An  entry  in  function  ISCANR  that  does  the  identical  pro- 
cessing but  starts  the  search  at  the  left  point.   If  the 
character  is  not  found,  the  right  point  value  plus  1  is 
returned. 
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Routine 

ISCANR  (L00K4, 
ISTART,  ISTOP. 
LIST) 


KF  (NSTN) 

KLIST  (IP,  NSTN) 

KO  (NSTN) 


MATCH  (ISTART. 
ISTOP,  LIST) 


NONL 


NONR  (L00K4, 
ISTART,  ISTOP, 
LIST) 


NUMBS  (ISTART, 
ISTOP,  LIST) 


OUTFRM 


Description 

A  function  that  returns  the  location  of  the  first  character 
matching  L00K4  in  array  LIST  between  the  left  point, 
ISTART,  and  the  right  point,  ISTOP.   The  search  is  started 
at  the  right  point.   If  a  matching  character  is  not  found, 
the  left  point  value  less  1  is  returned. 

A  subroutine  that  catalogs  the  FORMAT  statement  number  NSTN 
in  array  KFORM. 

A  logical  function  that  indicates  whether  the  internal 
statement  nxmiber  NSTN  from  the  position  indicated  by  IP 
has  been  properly  cataloged  in  array  INNUM. 

A  logical  function  that  indicates  whether  the  FORMAT  state- 
ment number  NSTN  has  been  properly  cataloged  in  array 
KFOUT  along  with  the  statement's  storage  position  and 
length. 

A  function  that  returns  the  location  of  the  matching  right 
parenthesis  corresponding  to  the  left  parenthesis  in  array 
LIST  location  ISTART.   If  a  matching  right  parenthesis  is 
not  found,  the  value  ISTOP  plus  1  is  returned. 

An  entry  in  function  NONR  which  does  the  identical  process- 
ing, but  starts  the  search  at  the  left  point.   If  a  non- 
matching  character  is  not  found,  the  right  point  value 
plus  1  is  returned. 

A  function  that  returns  the  location  of  the  first  character 
not  matching  L00K4  in  array  LIST  between  the  left  point, 
ISTART,  and  the  right  point,  ISTOP.   The  search  is  started 
at  the  right  point.   If  a  nonmatching  character  is  not 
found,  the  left  point  value  less  1  is  returned. 

A  function  that  returns  the  integer  value  of  the  number 
beginning  in  column  ISTART  of  array  LIST.   If  a  number  is 
found,  its  digits  are  suppressed  and  all  text  in  array 
LIST  through  column  ISTOP  is  shifted  left.   If  no  number 
is  found,  a  zero  is  returned.   Uses  routine  SHIFTL. 

A  subroutine  used  to  reconstruct  the  required  FORMAT  state- 
ments from  the  array  LFOUT.   It  is  driven  by  the  list  of 
original  statement  numbers  found  in  array  KFORM.   Uses 
following  routines:   INSERTN,  INSERTS,  ISCANL,  and 
PUNCHIT. 


OUTPUT  (LIST) 


A  subroutine  used  to  write  on  the  work  file  the  character 
string  contained  in  array  LIST. 
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Routine 


Description 


OUTSTR 


A  subroutine  used  to  reconstruct  the  type  statements  from 
array  STRING.   It  is  driven  by  the  number  of  typed  vari- 
ables contained  in  array  NUMBER.   Uses  following  routines: 
INSERTS,  NONR,  and  PUNCHIT. 


PUNCHIT  (ITY) 


A  subroutine  used  to  form  the  final  set  of  records  corre- 
sponding to  the  statement  type  indicated  by  ITY.   It  offers 
special  handling  to  the  Hollerith  fields  in  DATA  and 
FORMAT  statements.   Uses  following  routines:   FIXDATA  and 
ISCANR. 


READS 


A  subroutine  used  to  read  the  original  routine  from  TAPE  2, 
to  classify  statement  types,  and  to  write  the  working  file 
TAPE  10.   Uses  following  routines:   BLANKS,  CHECK,  IDENT, 
INSERT,  ISCANL,  KF,  KLIST,  KO  MATCH,  NONL,  NONR,  NUMBS, 
OUTPUT,  RESETS,  RESETX,  SHLFTL,  SPACOUT,  STORE,  and 
TRANSF. 


RESETS 


A  subroutine  that  resets  the  pointers,  counters,  and  arrays 
before  each  Fortran  routine  is  processed. 


RESETX 


An  entry  point  in  subroutine  RESETS  that  resets  the  point- 
ers, counters,  and  arrays  before  each  Fortran  statement  is 
processed. 


SHIFTL 


An  entry  point  in  subroutine  SHIFTR  that  does  the  identical 
processing,  but  removes  one  character  from  the  array.   All 
text  in  array  LIST  through  column  ISTOP  is  shifted  left 
one  column. 


SHIFTR  (NEW, 
ISTART,  ISTOP, 
LIST) 


A  subroutine  that  inserts  the  single  character  NEW  into  the 
array  LIST  just  prior  to  column  ISTART.  All  text  in  array 
LIST  through  column  ISTOP  is  shifted  right  one  column. 


SPACOUT 


A  subroutine  that  inserts  the  standard  spacing  into  the 
remainder  of  the  Fortran  statement.   Uses  following  rou- 
tines:  INSERT  and  MATCH. 


SPRESS  (I,  ISTOP, 
LIST) 


A  function  that  suppresses  a  string  of  blanks  starting  at 
LIST(I).   All  text  in  array  LIST  through  column  ISTOP  is 
shifted  left.   Zero  is  returned  if  LIST(I)  was  not  blank; 
one  is  returned  if  LIST(I)  was  blank. 


STORE  (JTYPE) 


A  subroutine  that  adds  a  new  list  of  variables  of  the  type 
indicated  by  JTYPE  to  those  already  stored  in  array  STRING. 
The  variables  are  alphanumerically  sorted  within  type. 
Uses  following  routines:   INSERT,  ISCANL,  and  MATCH. 
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Routine  Description 

SUMMARY  A  subroutine  that  cumulates  and  prints  the  summary  statis- 

tics for  each  routine  that  has  been  reorganized. 

TRANSF(I1,  12)     An  integer  function  that  returns  the  number  of  characters 

transferred  from  array  LCARD  to  array  LSTATE .   The  range 
of  the  transfer  from  array  LCARD  is  11  through  12. 

WRITES  A  subroutine  used  to  write  the  reorganized  routine  on 

TAPE  4.   Uses  following  routines:   INSERT,  INSERTN, 
OUTFRM,  OUTSTR,  PUNCHIT,  and  SUMMARY. 
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APPENDIX  C. --VARIABLE  DEFINITIONS 
APPENDIX  C  -  VaKlABLE  DEFIiMITIONb  A  FOHTNAN  KOUTINE  WEOKGAMZEK 

C  C  ALPHA  CMAKACTEP  C. 

C  END  ALPHA  WOPU  EMJ. 

C  H  ALPhA  ChAPACTEK  H, 

C  lA  (I, J)       FuPTHAi\  bTATEMENT  CHAPACTEP  DECUDEP  STRIi>JG» 

C  1=1  JUMP  ACDPESS  IF  CURKEM  CHAPACTEP  EXCEEDS 

C  MAl'CH  ChAPACTEP* 

C  I     =     i    MATCH  CHAPACTEP* 

C  1  =  3  NEXT  aCTIUi>I  if  MATCH, 

C  IF  <  0  CHECK  NEXT  CHAPACTEh*  IF  MATCH  ITYPE  = 

C  ABSOLUTE  VALUE  OF  lA  (3, J) 

C  IF  =  0  CHECK  NEXT  CHARACTER  AND  COiMTlNUEt 

C  IF  >  U  ITYPE  =  lA  (3. J) 

C  I8LAi\iK  ALPHA  ImOPU  i3LANK. 

C  ICHAKb  LENGTH  OF  CUkKENT  STaTEMENF  UH  TO  THE  i  bIGN,  <  LCHAKb, 

C  IOOLLaP        INDICATES  THE  POSITION  OF  THE  END  OF  THE  CUPwEnT 

C  STATEMENT  '/,HEN  A  i  SEPAPATOP  HAS  BEEN  USED. 

C  lEOF  IimDICATES  ThE  EOF  INDICATOP  HAS  BEEN  ENCOUNTERED. 

C  0  r*  KU  OP  1  r^  YES. 

C  lEPROR  EPPOk  INUICATOK,  COkRESPONDS  TC  ITYPE. 

C  INNUM  (I.j)    Ii^jTERNAL  bTATEKENT  NUMBER  CODES, 

C  1=1  CHARACTER  COUNT  POSITION  IN  STATEMENT, 

C  1=2    OWIGINAL  STATEMENT  NUMBER. 

C  INTEGER*  (I)     STRING  OF  INTEGERS  IN  CHAKACTEH  FORMAT. 

C  IPOINT  NEXT  POSITION  AFTEw  CHECK  wOHD. 

C  IPROG  ROUTINE  T fHE ,  CORRESPONDS  TO  ITYPE. 

C  100  r>    Ef-!ROR,  NO  KOUTINE  TYPE  RECORD. 

C  IPUNCT   (I)     STRING  OF  PUNCTUATION  MARKS  IN  CHARACTER  FORMAT. 

C  ISNUM  REVISED  STATEMENT  NUMbER  FOR  THE  CORRENT  STATEMENT. 

C  ITYPE  STATEMENT  TYPE 

C         KOUTI^^;E  STATEMENTS: 

C  1   PROGKAy  2   bUBRUUTINE        3   FUNCTION 

C  u       BLOCK  DATA       100  ERROk 

C         TYPE  STATEMENTS: 

C  ■-,   COMMON/  6   COMMON  7   DIMENSION 

C  M   EXTERNAL  9   COMPLEX  10  DOUh^lE  PRECISION 

C  11  INTEGEk  1^  LOGICAL  13  REAL 

C  ^1  TYPE 

C         DEFINITION  STATEMENTS: 

C  i5  EUOIVALENCE       16  DATA  17  FuRMAT 

C         EXECUTABLE  STATEMENTS: 

C  iB  DO  19  GO  TO  (  20  GO  TO 

C  ?l     IF  22  CALL  23  ASSIGN 

C  ?^    CONTlNUt  25  READ  (  26  READ 

C  ^7  PRINT  28  WRITE  (  ^9  PUNCH 

C  30  RUFFEk  in         31  BUFFER  OUT        32  DECODE 

C  33  ENCODE  34  STOP  35  ENTRY 

C  ^6  RETORn  37  USE  38  ENDFILE 

C  ^9    WEwlND  40  BACkSPACL         42  PAUSE 

C  43  NAMELI-T  44  END  ^5  ( KEPL ACEMEN T ) 

C  12  POSITION  OF  NEXT  COMMA. 

C  13  POSITION  OF  NEXT  LEFT  PARENTHESIS. 

C  14  POSITION  OF  NEXT  RIGHT  PARENTHtSIS. 

C  19999  INDICATES  IF  A  RETURN  STATEMENT  HAS  BEEl^)  PkOCESSED, 

C  0  r*  NO  OR  1  r»  YES. 

C  ,   KFOKM  (I)       OKIGINAL  FORMAT  NUMBER  LIST  BY  OkDER  OF  USAGE. 

C  KFOUT  (I, J)    FORMAT  STATEMENT  STORAGE  DATA, 

C  1=1  OKIGINAL  STATEMENT  NUMBER* 

C  1    =    k    STARTING  POSITION  IN  ARRAY  LFOUT, 

C  1=3  LENGTH  OF  STATEMENT  IN  CHARACTERS. 

C  KSNUM  (I, J)    STATEMENT  NUMBER  DATA, 


i 
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APPEi\DIX  C  -  VAKIABLt  DEFINITIONS 


A  FOKTHAN  ROUTINE  KEORGANIZEK 


C 
C 

c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 


LCAkD  (I) 
LCHAKS 

LEOUT  (l) 

LSTATE  (I) 

LUIN 

LUOUT 

LUSTATE 

LWOh(DS 

NAME  (I) 

NCAKD 

NCAKDS 

NEXT 

NEOKMN 

NFOUT 

NOUTS 

NPUSri 

NSNUMC 

NSTATN 

NUM  IN 


NUMK 
NUMBtK 


(I) 


NVALUE 

RETUKN 

STAf^ 

STRING  (I, J) 

X 


I  = 

I  = 

IisiPUT 
LENGT 

<  M 
FOKMA 
CURRE 
LOGIC 
LOGIC 
LOGIC 
LENGT 
PKOGR 
NUiMBE 
NUMHE 
POINT 
NUMBE 
POINT 
NUMBE 
NUMBE 
CUKKt 
NUMBE 
inUMBE 

STa 

NUMBE 
NUMBE 
I  = 
I  = 
I  = 
I  = 

okigi 

ALPHA 
ALPHA 
STORA 
ALPHA 


1  ORIGINA 

Z    NEW  STA 

DATA  CAKD 

H  OF  CURRE 

LCHARS  =  2 

T  STATEMEN 

NT  STATEME 

AL  UNIT  OF 

AL  UNIT  OF 

AL  UNIT  OF 

h  OF  CURRE 

AM  NAME  ON 

R  OF  RECOR 

R  OF  RECOR 

ER  FOR  THE 

R  OF  FORMA 

ER  FOR  ARR 

R  OF  OUTPU 

R  OF  SIMUL 

NT  NEiN  STA 

R  OF  PROGR 

R  OF  INTER 

TEMENT*  PO 

R  OF  WORD 

R  OF  VARIA 

1  DIMENSI 

J  COMPLEX 

5  INTEGEH 

7  REAL 

NAL  STATEM 

/jORD  RETU 

CHARACTER 

GE  ARRAY  F 

CHARACTER 


L  STATEMENT  NUM 
TEMENT  NUMBER. 

RECORD  IN  CHAR 
NT  STATEMENT  IN 
000. 

T  bTORAGE  ARRAY 
NT  IN  CHARACTER 
THE  INPUT  FILE 
THE  OUTPUT  FIL 
THE  WORKING  FI 
NT  STATEMENT  IN 
OUTPUT  RECORDS 
DS  READ  FOR  THE 
DS  WRITTEN  FOR 
ARRAY  LFOUT  < 
T  STATEMENTS  < 
AY  KFOUT. 
T  RECORDS  ON  TH 
TANEOUS  DO  LOOP 
TEMENT  NUMBER. 
AM  STATEMENT  NU 
NAL  STATEMENT  N 
INTER  IN  ARRAY 
PAIRS  IN  AKKAY 
BLEb  OF  EACH  TY 
ON  I 

I 
I 


BER, 

ACTER  FORM. 
CHAKACTERS 


FORM. 

♦  TAPE2. 
E»  TAPEA. 
LE»  TAPEIO. 

WORDS  <  200. 

♦  IN  CHARACTER  FORMAT. 
CURRENT  STATEMENT. 

THE  CURRENT  ROUTINE. 
h'FOUT  =  1000. 
MNFORM  =  99. 

E  FILE  LUSTATE. 
S. 

INITIALLY  =  990. 
MBERS  <  MNSTATE  =  ^00. 
UMBERS  FOk  current 
INNUM  <  NUMMAX  =  50. 
STRING  <  NMAX  =  100. 
PE  IN  (STRING). 
=  2  EXTERNAL 
=  4  DOUBLE  PRECISION 
=  6  LOGICAL 


ENT  NUMBER  ^V    THE  CURRENT  STATEMENT. 

OR  TYPE  STATEMENT  VARIABLES. 
X. 
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APPENDIX  D, --SCOPE   CONTROL  CARDS 

APPENDIX    0    -    SCOHF    CUNlKOL    C/wCS  A    FOPlHAN    kOUTIimE    hEOKGAMZEk 

ATTACh^PEuK^H-E.jK, 

KEQUEST,TAKE'^t»-"-PF. 

ATTACH  ♦TAPE?»S',:UKCEP^^OGkAi-i. 

PFL(b5000) 

WEDUCE. 

SET(O) 

(v-ODE  (0) 

tVEOK. 

CATALOG*  TAHh'^^^     UUKCtPKOC-r^AHHtOK. 


PD  -  22.2. 


INT.-BU.OF   MINES, PGH., PA.    20709 


1 


T>  U.S.  GOVERNMENT  PRINTING  OFFICE:  1975-603-755/50 
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